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,ehomology_constr
 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 !       print *,"wstrain check", wstrain
 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       if (constr_homology.ge.1) then
 749         call e_modeller(ehomology_constr)
 750 !        print *,'iset=',iset,'me=',me,ehomology_constr,
 751 !     &  'Processor',fg_rank,' CG group',kolor,
 752 !     &  ' absolute rank',MyRank
 753 !       print *,"tu"
 754       else
 755         ehomology_constr=0.0d0
 756       endif
 757
 758 !
 759 ! 6/23/01 Calculate double-torsional energy
 760 !
 761 !elwrite(iout,*) "in etotal",ipot
 762       if (wtor_d.gt.0) then
 763        call etor_d(etors_d)
 764       else
 765        etors_d=0
 766       endif
 767 !      print *,"Processor",myrank," computed Utord"
 768 !
 769 ! 21/5/07 Calculate local sicdechain correlation energy
 770 !
 771       if (wsccor.gt.0.0d0) then
 772         call eback_sc_corr(esccor)
 773       else
 774         esccor=0.0d0
 775       endif
 776
 777 !      write(iout,*) "before multibody"
 778       call flush(iout)
 779 !      print *,"Processor",myrank," computed Usccorr"
 780 !
 781 ! 12/1/95 Multi-body terms
 782 !
 783       n_corr=0
 784       n_corr1=0
 785       call flush(iout)
 786       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 787           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 788          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 789 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 790 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 791       else
 792          ecorr=0.0d0
 793          ecorr5=0.0d0
 794          ecorr6=0.0d0
 795          eturn6=0.0d0
 796       endif
 797 !elwrite(iout,*) "in etotal",ipot
 798       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 799          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 800 !d         write (iout,*) "multibody_hb ecorr",ecorr
 801       endif
 802 !      write(iout,*) "afeter  multibody hb"
 803
 804 !      print *,"Processor",myrank," computed Ucorr"
 805 !
 806 ! If performing constraint dynamics, call the constraint energy
 807 !  after the equilibration time
 808       if((usampl).and.(totT.gt.eq_time)) then
 809         write(iout,*) "usampl",usampl
 810          call EconstrQ
 811 !elwrite(iout,*) "afeter  multibody hb"
 812          call Econstr_back
 813 !elwrite(iout,*) "afeter  multibody hb"
 814       else
 815          Uconst=0.0d0
 816          Uconst_back=0.0d0
 817       endif
 818       call flush(iout)
 819 !         write(iout,*) "after Econstr"
 820
 821       if (wliptran.gt.0) then
 822 !        print *,"PRZED WYWOLANIEM"
 823         call Eliptransfer(eliptran)
 824       else
 825        eliptran=0.0d0
 826       endif
 827       if (fg_rank.eq.0) then
 828       if (AFMlog.gt.0) then
 829         call AFMforce(Eafmforce)
 830       else if (selfguide.gt.0) then
 831         call AFMvel(Eafmforce)
 832       else
 833         Eafmforce=0.0d0
 834       endif
 835       endif
 836       if (tubemode.eq.1) then
 837        call calctube(etube)
 838       else if (tubemode.eq.2) then
 839        call calctube2(etube)
 840       elseif (tubemode.eq.3) then
 841        call calcnano(etube)
 842       else
 843        etube=0.0d0
 844       endif
 845 !--------------------------------------------------------
 846 !       write (iout,*) "NRES_MOLEC(2),",nres_molec(2)
 847 !      print *,"before",ees,evdw1,ecorr
 848 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 849       if (nres_molec(2).gt.0) then
 850       call ebond_nucl(estr_nucl)
 851       call ebend_nucl(ebe_nucl)
 852       call etor_nucl(etors_nucl)
 853       call esb_gb(evdwsb,eelsb)
 854       call epp_nucl_sub(evdwpp,eespp)
 855       call epsb(evdwpsb,eelpsb)
 856       call esb(esbloc)
 857       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 858             call ecat_nucl(ecation_nucl)
 859       else
 860        etors_nucl=0.0d0
 861        estr_nucl=0.0d0
 862        ecorr3_nucl=0.0d0
 863        ecorr_nucl=0.0d0
 864        ebe_nucl=0.0d0
 865        evdwsb=0.0d0
 866        eelsb=0.0d0
 867        esbloc=0.0d0
 868        evdwpsb=0.0d0
 869        eelpsb=0.0d0
 870        evdwpp=0.0d0
 871        eespp=0.0d0
 872        etors_d_nucl=0.0d0
 873        ecation_nucl=0.0d0
 874       endif
 875 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 876 !      print *,"before ecatcat",wcatcat
 877       if (nres_molec(5).gt.0) then
 878       if (nfgtasks.gt.1) then
 879       if (fg_rank.eq.0) then
 880       call ecatcat(ecationcation)
 881       endif
 882       else
 883       call ecatcat(ecationcation)
 884       endif
 885       if (oldion.gt.0) then
 886       call ecat_prot(ecation_prot)
 887       else
 888       call ecats_prot_amber(ecation_prot)
 889       endif
 890       else
 891       ecationcation=0.0d0
 892       ecation_prot=0.0d0
 893       endif
 894       if ((nres_molec(2).gt.0).and.(nres_molec(1).gt.0)) then
 895       call eprot_sc_base(escbase)
 896       call epep_sc_base(epepbase)
 897       call eprot_sc_phosphate(escpho)
 898       call eprot_pep_phosphate(epeppho)
 899       else
 900       epepbase=0.0
 901       escbase=0.0
 902       escpho=0.0
 903       epeppho=0.0
 904       endif
 905 !      call ecatcat(ecationcation)
 906 !      print *,"after ebend", wtor_nucl
 907 #ifdef TIMING
 908       time_enecalc=time_enecalc+MPI_Wtime()-time00
 909 #endif
 910 !      print *,"Processor",myrank," computed Uconstr"
 911 #ifdef TIMING
 912       time00=MPI_Wtime()
 913 #endif
 914 !
 915 ! Sum the energies
 916 !
 917       energia(1)=evdw
 918 #ifdef SCP14
 919       energia(2)=evdw2-evdw2_14
 920       energia(18)=evdw2_14
 921 #else
 922       energia(2)=evdw2
 923       energia(18)=0.0d0
 924 #endif
 925 #ifdef SPLITELE
 926       energia(3)=ees
 927       energia(16)=evdw1
 928 #else
 929       energia(3)=ees+evdw1
 930       energia(16)=0.0d0
 931 #endif
 932       energia(4)=ecorr
 933       energia(5)=ecorr5
 934       energia(6)=ecorr6
 935       energia(7)=eel_loc
 936       energia(8)=eello_turn3
 937       energia(9)=eello_turn4
 938       energia(10)=eturn6
 939       energia(11)=ebe
 940       energia(12)=escloc
 941       energia(13)=etors
 942       energia(14)=etors_d
 943       energia(15)=ehpb
 944       energia(19)=edihcnstr
 945       energia(17)=estr
 946       energia(20)=Uconst+Uconst_back
 947       energia(21)=esccor
 948       energia(22)=eliptran
 949       energia(23)=Eafmforce
 950       energia(24)=ethetacnstr
 951       energia(25)=etube
 952 !---------------------------------------------------------------
 953       energia(26)=evdwpp
 954       energia(27)=eespp
 955       energia(28)=evdwpsb
 956       energia(29)=eelpsb
 957       energia(30)=evdwsb
 958       energia(31)=eelsb
 959       energia(32)=estr_nucl
 960       energia(33)=ebe_nucl
 961       energia(34)=esbloc
 962       energia(35)=etors_nucl
 963       energia(36)=etors_d_nucl
 964       energia(37)=ecorr_nucl
 965       energia(38)=ecorr3_nucl
 966 !----------------------------------------------------------------------
 967 !    Here are the energies showed per procesor if the are more processors
 968 !    per molecule then we sum it up in sum_energy subroutine
 969 !      print *," Processor",myrank," calls SUM_ENERGY"
 970       energia(42)=ecation_prot
 971       energia(41)=ecationcation
 972       energia(46)=escbase
 973       energia(47)=epepbase
 974       energia(48)=escpho
 975       energia(49)=epeppho
 976 !      energia(50)=ecations_prot_amber
 977       energia(50)=ecation_nucl
 978       energia(51)=ehomology_constr
 979       call sum_energy(energia,.true.)
 980       if (dyn_ss) call dyn_set_nss
 981 !      print *," Processor",myrank," left SUM_ENERGY"
 982 #ifdef TIMING
 983       time_sumene=time_sumene+MPI_Wtime()-time00
 984 #endif
 985 !        call enerprint(energia)
 986 !elwrite(iout,*)"finish etotal"
 987       return
 988       end subroutine etotal
 989 !-----------------------------------------------------------------------------
 990       subroutine sum_energy(energia,reduce)
 991 !      implicit real*8 (a-h,o-z)
 992 !      include 'DIMENSIONS'
 993 #ifndef ISNAN
 994       external proc_proc
 995 #ifdef WINPGI
 996 !MS$ATTRIBUTES C ::  proc_proc
 997 #endif
 998 #endif
 999 #ifdef MPI
1000       include "mpif.h"
1001 #endif
1002 !      include 'COMMON.SETUP'
1003 !      include 'COMMON.IOUNITS'
1004       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
1005 !      include 'COMMON.FFIELD'
1006 !      include 'COMMON.DERIV'
1007 !      include 'COMMON.INTERACT'
1008 !      include 'COMMON.SBRIDGE'
1009 !      include 'COMMON.CHAIN'
1010 !      include 'COMMON.VAR'
1011 !      include 'COMMON.CONTROL'
1012 !      include 'COMMON.TIME1'
1013       logical :: reduce
1014       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
1015       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
1016       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
1017         eliptran,etube, Eafmforce,ethetacnstr
1018       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1019                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1020                       ecorr3_nucl,ehomology_constr
1021       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,&
1022                       ecation_nucl
1023       real(kind=8) :: escbase,epepbase,escpho,epeppho
1024       integer :: i
1025 #ifdef MPI
1026       integer :: ierr
1027       real(kind=8) :: time00
1028       if (nfgtasks.gt.1 .and. reduce) then
1029
1030 #ifdef DEBUG
1031         write (iout,*) "energies before REDUCE"
1032         call enerprint(energia)
1033         call flush(iout)
1034 #endif
1035         do i=0,n_ene
1036           enebuff(i)=energia(i)
1037         enddo
1038         time00=MPI_Wtime()
1039         call MPI_Barrier(FG_COMM,IERR)
1040         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
1041         time00=MPI_Wtime()
1042         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
1043           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
1044 #ifdef DEBUG
1045         write (iout,*) "energies after REDUCE"
1046         call enerprint(energia)
1047         call flush(iout)
1048 #endif
1049         time_Reduce=time_Reduce+MPI_Wtime()-time00
1050       endif
1051       if (fg_rank.eq.0) then
1052 #endif
1053       evdw=energia(1)
1054 #ifdef SCP14
1055       evdw2=energia(2)+energia(18)
1056       evdw2_14=energia(18)
1057 #else
1058       evdw2=energia(2)
1059 #endif
1060 #ifdef SPLITELE
1061       ees=energia(3)
1062       evdw1=energia(16)
1063 #else
1064       ees=energia(3)
1065       evdw1=0.0d0
1066 #endif
1067       ecorr=energia(4)
1068       ecorr5=energia(5)
1069       ecorr6=energia(6)
1070       eel_loc=energia(7)
1071       eello_turn3=energia(8)
1072       eello_turn4=energia(9)
1073       eturn6=energia(10)
1074       ebe=energia(11)
1075       escloc=energia(12)
1076       etors=energia(13)
1077       etors_d=energia(14)
1078       ehpb=energia(15)
1079       edihcnstr=energia(19)
1080       estr=energia(17)
1081       Uconst=energia(20)
1082       esccor=energia(21)
1083       eliptran=energia(22)
1084       Eafmforce=energia(23)
1085       ethetacnstr=energia(24)
1086       etube=energia(25)
1087       evdwpp=energia(26)
1088       eespp=energia(27)
1089       evdwpsb=energia(28)
1090       eelpsb=energia(29)
1091       evdwsb=energia(30)
1092       eelsb=energia(31)
1093       estr_nucl=energia(32)
1094       ebe_nucl=energia(33)
1095       esbloc=energia(34)
1096       etors_nucl=energia(35)
1097       etors_d_nucl=energia(36)
1098       ecorr_nucl=energia(37)
1099       ecorr3_nucl=energia(38)
1100       ecation_prot=energia(42)
1101       ecationcation=energia(41)
1102       escbase=energia(46)
1103       epepbase=energia(47)
1104       escpho=energia(48)
1105       epeppho=energia(49)
1106       ecation_nucl=energia(50)
1107       ehomology_constr=energia(51)
1108 !      ecations_prot_amber=energia(50)
1109
1110 !      energia(41)=ecation_prot
1111 !      energia(42)=ecationcation
1112
1113
1114 #ifdef SPLITELE
1115       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
1116        +wang*ebe+wtor*etors+wscloc*escloc &
1117        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1118        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1119        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1120        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1121        +Eafmforce+ethetacnstr  &
1122        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1123        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1124        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1125        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1126        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1127        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho+wcatnucl*ecation_nucl&
1128 #ifdef WHAM_RUN
1129        +0.0d0
1130 #else
1131        +ehomology_constr
1132 #endif
1133 #else
1134       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
1135        +wang*ebe+wtor*etors+wscloc*escloc &
1136        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1137        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1138        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1139        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1140        +Eafmforce+ethetacnstr &
1141        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1142        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1143        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1144        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1145        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1146        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho+wcatnucl*ecation_nucl
1147 #ifdef WHAM_RUN
1148        +0.0d0
1149 #else
1150        +ehomology_constr
1151 #endif
1152 #endif
1153       energia(0)=etot
1154 ! detecting NaNQ
1155 #ifdef ISNAN
1156 #ifdef AIX
1157       if (isnan(etot).ne.0) energia(0)=1.0d+99
1158 #else
1159       if (isnan(etot)) energia(0)=1.0d+99
1160 #endif
1161 #else
1162       i=0
1163 #ifdef WINPGI
1164       idumm=proc_proc(etot,i)
1165 #else
1166       call proc_proc(etot,i)
1167 #endif
1168       if(i.eq.1)energia(0)=1.0d+99
1169 #endif
1170 #ifdef MPI
1171       endif
1172 #endif
1173 !      call enerprint(energia)
1174       call flush(iout)
1175       return
1176       end subroutine sum_energy
1177 !-----------------------------------------------------------------------------
1178       subroutine rescale_weights(t_bath)
1179 !      implicit real*8 (a-h,o-z)
1180 #ifdef MPI
1181       include 'mpif.h'
1182 #endif
1183 !      include 'DIMENSIONS'
1184 !      include 'COMMON.IOUNITS'
1185 !      include 'COMMON.FFIELD'
1186 !      include 'COMMON.SBRIDGE'
1187       real(kind=8) :: kfac=2.4d0
1188       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
1189 !el local variables
1190       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
1191       real(kind=8) :: T0=3.0d2
1192       integer :: ierror
1193 !      facT=temp0/t_bath
1194 !      facT=2*temp0/(t_bath+temp0)
1195       if (rescale_mode.eq.0) then
1196         facT(1)=1.0d0
1197         facT(2)=1.0d0
1198         facT(3)=1.0d0
1199         facT(4)=1.0d0
1200         facT(5)=1.0d0
1201         facT(6)=1.0d0
1202       else if (rescale_mode.eq.1) then
1203         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
1204         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1205         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1206         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1207         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1208 #ifdef WHAM_RUN
1209 !#if defined(WHAM_RUN) || defined(CLUSTER)
1210 #if defined(FUNCTH)
1211 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
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 if (rescale_mode.eq.2) then
1220         x=t_bath/temp0
1221         x2=x*x
1222         x3=x2*x
1223         x4=x3*x
1224         x5=x4*x
1225         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
1226         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
1227         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
1228         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
1229         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
1230 #ifdef WHAM_RUN
1231 !#if defined(WHAM_RUN) || defined(CLUSTER)
1232 #if defined(FUNCTH)
1233         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1234 #elif defined(FUNCT)
1235         facT(6)=t_bath/T0
1236 #else
1237         facT(6)=1.0d0
1238 #endif
1239 #endif
1240       else
1241         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1242         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1243 #ifdef MPI
1244        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1245 #endif
1246        stop 555
1247       endif
1248       welec=weights(3)*fact(1)
1249       wcorr=weights(4)*fact(3)
1250       wcorr5=weights(5)*fact(4)
1251       wcorr6=weights(6)*fact(5)
1252       wel_loc=weights(7)*fact(2)
1253       wturn3=weights(8)*fact(2)
1254       wturn4=weights(9)*fact(3)
1255       wturn6=weights(10)*fact(5)
1256       wtor=weights(13)*fact(1)
1257       wtor_d=weights(14)*fact(2)
1258       wsccor=weights(21)*fact(1)
1259       welpsb=weights(28)*fact(1)
1260       wcorr_nucl= weights(37)*fact(1)
1261       wcorr3_nucl=weights(38)*fact(2)
1262       wtor_nucl=  weights(35)*fact(1)
1263       wtor_d_nucl=weights(36)*fact(2)
1264       wpepbase=weights(47)*fact(1)
1265       return
1266       end subroutine rescale_weights
1267 !-----------------------------------------------------------------------------
1268       subroutine enerprint(energia)
1269 !      implicit real*8 (a-h,o-z)
1270 !      include 'DIMENSIONS'
1271 !      include 'COMMON.IOUNITS'
1272 !      include 'COMMON.FFIELD'
1273 !      include 'COMMON.SBRIDGE'
1274 !      include 'COMMON.MD'
1275       real(kind=8) :: energia(0:n_ene)
1276 !el local variables
1277       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
1278       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
1279       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
1280        etube,ethetacnstr,Eafmforce
1281       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1282                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1283                       ecorr3_nucl,ehomology_constr
1284       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,&
1285                       ecation_nucl
1286       real(kind=8) :: escbase,epepbase,escpho,epeppho
1287
1288       etot=energia(0)
1289       evdw=energia(1)
1290       evdw2=energia(2)
1291 #ifdef SCP14
1292       evdw2=energia(2)+energia(18)
1293 #else
1294       evdw2=energia(2)
1295 #endif
1296       ees=energia(3)
1297 #ifdef SPLITELE
1298       evdw1=energia(16)
1299 #endif
1300       ecorr=energia(4)
1301       ecorr5=energia(5)
1302       ecorr6=energia(6)
1303       eel_loc=energia(7)
1304       eello_turn3=energia(8)
1305       eello_turn4=energia(9)
1306       eello_turn6=energia(10)
1307       ebe=energia(11)
1308       escloc=energia(12)
1309       etors=energia(13)
1310       etors_d=energia(14)
1311       ehpb=energia(15)
1312       edihcnstr=energia(19)
1313       estr=energia(17)
1314       Uconst=energia(20)
1315       esccor=energia(21)
1316       eliptran=energia(22)
1317       Eafmforce=energia(23)
1318       ethetacnstr=energia(24)
1319       etube=energia(25)
1320       evdwpp=energia(26)
1321       eespp=energia(27)
1322       evdwpsb=energia(28)
1323       eelpsb=energia(29)
1324       evdwsb=energia(30)
1325       eelsb=energia(31)
1326       estr_nucl=energia(32)
1327       ebe_nucl=energia(33)
1328       esbloc=energia(34)
1329       etors_nucl=energia(35)
1330       etors_d_nucl=energia(36)
1331       ecorr_nucl=energia(37)
1332       ecorr3_nucl=energia(38)
1333       ecation_prot=energia(42)
1334       ecationcation=energia(41)
1335       escbase=energia(46)
1336       epepbase=energia(47)
1337       escpho=energia(48)
1338       epeppho=energia(49)
1339       ecation_nucl=energia(50)
1340       ehomology_constr=energia(51)
1341
1342 !      ecations_prot_amber=energia(50)
1343 #ifdef SPLITELE
1344       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1345         estr,wbond,ebe,wang,&
1346         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1347         ecorr,wcorr,&
1348         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1349         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1350         edihcnstr,ethetacnstr,ebr*nss,&
1351         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1352         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1353         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1354         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1355         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1356         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1357         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1358         ecation_nucl,wcatnucl,ehomology_constr,etot
1359    10 format (/'Virtual-chain energies:'// &
1360        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1361        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1362        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1363        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1364        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1365        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1366        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1367        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1368        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1369        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1370        ' (SS bridges & dist. cnstr.)'/ &
1371        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1372        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1373        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1374        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1375        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1376        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1377        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1378        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1379        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1380        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1381        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1382        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1383        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1384        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1385        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1386        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1387        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1388        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1389        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1390        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1391        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1392        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1393        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1394        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1395        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1396        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1397        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1398        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1399        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1400        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1401        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1402        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1403        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1404        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1405        'ECATBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(cation nucl-base)'/&
1406        'H_CONS=',1pE16.6,' (Homology model constraints energy)'/&
1407        'ETOT=  ',1pE16.6,' (total)')
1408 #else
1409       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1410         estr,wbond,ebe,wang,&
1411         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1412         ecorr,wcorr,&
1413         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1414         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1415         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforce,     &
1416         etube,wtube, ehomology_constr,&
1417         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1418         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1419         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1420         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1421         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1422         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1423         ecation_nucl,wcatnucl,ehomology_constr,etot
1424    10 format (/'Virtual-chain energies:'// &
1425        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1426        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1427        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1428        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1429        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1430        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1431        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1432        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1433        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1434        ' (SS bridges & dist. cnstr.)'/ &
1435        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1436        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1437        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1438        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1439        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1440        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1441        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1442        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1443        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1444        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1445        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1446        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1447        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1448        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1449        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1450        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1451        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1452        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1453        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1454        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1455        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1456        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1457        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1458        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1459        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1460        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1461        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1462        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1463        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1464        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1465        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1466        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1467        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1468        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1469        'ECATBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(cation nucl-base)'/&
1470        'H_CONS=',1pE16.6,' (Homology model constraints energy)'/&
1471        'ETOT=  ',1pE16.6,' (total)')
1472 #endif
1473       return
1474       end subroutine enerprint
1475 !-----------------------------------------------------------------------------
1476       subroutine elj(evdw)
1477 !
1478 ! This subroutine calculates the interaction energy of nonbonded side chains
1479 ! assuming the LJ potential of interaction.
1480 !
1481 !      implicit real*8 (a-h,o-z)
1482 !      include 'DIMENSIONS'
1483       real(kind=8),parameter :: accur=1.0d-10
1484 !      include 'COMMON.GEO'
1485 !      include 'COMMON.VAR'
1486 !      include 'COMMON.LOCAL'
1487 !      include 'COMMON.CHAIN'
1488 !      include 'COMMON.DERIV'
1489 !      include 'COMMON.INTERACT'
1490 !      include 'COMMON.TORSION'
1491 !      include 'COMMON.SBRIDGE'
1492 !      include 'COMMON.NAMES'
1493 !      include 'COMMON.IOUNITS'
1494 !      include 'COMMON.CONTACTS'
1495       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1496       integer :: num_conti
1497 !el local variables
1498       integer :: i,itypi,iint,j,itypi1,itypj,k
1499       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij,sslipi,ssgradlipi,&
1500        aa,bb,sslipj,ssgradlipj
1501       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1502       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1503
1504 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1505       evdw=0.0D0
1506 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1507 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1508 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1509 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1510
1511       do i=iatsc_s,iatsc_e
1512         itypi=iabs(itype(i,1))
1513         if (itypi.eq.ntyp1) cycle
1514         itypi1=iabs(itype(i+1,1))
1515         xi=c(1,nres+i)
1516         yi=c(2,nres+i)
1517         zi=c(3,nres+i)
1518         call to_box(xi,yi,zi)
1519         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1520
1521 ! Change 12/1/95
1522         num_conti=0
1523 !
1524 ! Calculate SC interaction energy.
1525 !
1526         do iint=1,nint_gr(i)
1527 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1528 !d   &                  'iend=',iend(i,iint)
1529           do j=istart(i,iint),iend(i,iint)
1530             itypj=iabs(itype(j,1))
1531             if (itypj.eq.ntyp1) cycle
1532             xj=c(1,nres+j)-xi
1533             yj=c(2,nres+j)-yi
1534             zj=c(3,nres+j)-zi
1535             call to_box(xj,yj,zj)
1536             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1537             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1538              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1539             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1540              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1541             xj=boxshift(xj-xi,boxxsize)
1542             yj=boxshift(yj-yi,boxysize)
1543             zj=boxshift(zj-zi,boxzsize)
1544 ! Change 12/1/95 to calculate four-body interactions
1545             rij=xj*xj+yj*yj+zj*zj
1546             rrij=1.0D0/rij
1547 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1548             eps0ij=eps(itypi,itypj)
1549             fac=rrij**expon2
1550             e1=fac*fac*aa_aq(itypi,itypj)
1551             e2=fac*bb_aq(itypi,itypj)
1552             evdwij=e1+e2
1553 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1554 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1555 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1556 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1557 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1558 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1559             evdw=evdw+evdwij
1560 !
1561 ! Calculate the components of the gradient in DC and X
1562 !
1563             fac=-rrij*(e1+evdwij)
1564             gg(1)=xj*fac
1565             gg(2)=yj*fac
1566             gg(3)=zj*fac
1567             do k=1,3
1568               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1569               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1570               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1571               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1572             enddo
1573 !grad            do k=i,j-1
1574 !grad              do l=1,3
1575 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1576 !grad              enddo
1577 !grad            enddo
1578 !
1579 ! 12/1/95, revised on 5/20/97
1580 !
1581 ! Calculate the contact function. The ith column of the array JCONT will
1582 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1583 ! greater than I). The arrays FACONT and GACONT will contain the values of
1584 ! the contact function and its derivative.
1585 !
1586 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1587 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1588 ! Uncomment next line, if the correlation interactions are contact function only
1589             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1590               rij=dsqrt(rij)
1591               sigij=sigma(itypi,itypj)
1592               r0ij=rs0(itypi,itypj)
1593 !
1594 ! Check whether the SC's are not too far to make a contact.
1595 !
1596               rcut=1.5d0*r0ij
1597               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1598 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1599 !
1600               if (fcont.gt.0.0D0) then
1601 ! If the SC-SC distance if close to sigma, apply spline.
1602 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1603 !Adam &             fcont1,fprimcont1)
1604 !Adam           fcont1=1.0d0-fcont1
1605 !Adam           if (fcont1.gt.0.0d0) then
1606 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1607 !Adam             fcont=fcont*fcont1
1608 !Adam           endif
1609 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1610 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1611 !ga             do k=1,3
1612 !ga               gg(k)=gg(k)*eps0ij
1613 !ga             enddo
1614 !ga             eps0ij=-evdwij*eps0ij
1615 ! Uncomment for AL's type of SC correlation interactions.
1616 !adam           eps0ij=-evdwij
1617                 num_conti=num_conti+1
1618                 jcont(num_conti,i)=j
1619                 facont(num_conti,i)=fcont*eps0ij
1620                 fprimcont=eps0ij*fprimcont/rij
1621                 fcont=expon*fcont
1622 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1623 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1624 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1625 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1626                 gacont(1,num_conti,i)=-fprimcont*xj
1627                 gacont(2,num_conti,i)=-fprimcont*yj
1628                 gacont(3,num_conti,i)=-fprimcont*zj
1629 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1630 !d              write (iout,'(2i3,3f10.5)')
1631 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1632               endif
1633             endif
1634           enddo      ! j
1635         enddo        ! iint
1636 ! Change 12/1/95
1637         num_cont(i)=num_conti
1638       enddo          ! i
1639       do i=1,nct
1640         do j=1,3
1641           gvdwc(j,i)=expon*gvdwc(j,i)
1642           gvdwx(j,i)=expon*gvdwx(j,i)
1643         enddo
1644       enddo
1645 !******************************************************************************
1646 !
1647 !                              N O T E !!!
1648 !
1649 ! To save time, the factor of EXPON has been extracted from ALL components
1650 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1651 ! use!
1652 !
1653 !******************************************************************************
1654       return
1655       end subroutine elj
1656 !-----------------------------------------------------------------------------
1657       subroutine eljk(evdw)
1658 !
1659 ! This subroutine calculates the interaction energy of nonbonded side chains
1660 ! assuming the LJK potential of interaction.
1661 !
1662 !      implicit real*8 (a-h,o-z)
1663 !      include 'DIMENSIONS'
1664 !      include 'COMMON.GEO'
1665 !      include 'COMMON.VAR'
1666 !      include 'COMMON.LOCAL'
1667 !      include 'COMMON.CHAIN'
1668 !      include 'COMMON.DERIV'
1669 !      include 'COMMON.INTERACT'
1670 !      include 'COMMON.IOUNITS'
1671 !      include 'COMMON.NAMES'
1672       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1673       logical :: scheck
1674 !el local variables
1675       integer :: i,iint,j,itypi,itypi1,k,itypj
1676       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij, &
1677          sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb
1678       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1679
1680 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1681       evdw=0.0D0
1682       do i=iatsc_s,iatsc_e
1683         itypi=iabs(itype(i,1))
1684         if (itypi.eq.ntyp1) cycle
1685         itypi1=iabs(itype(i+1,1))
1686         xi=c(1,nres+i)
1687         yi=c(2,nres+i)
1688         zi=c(3,nres+i)
1689         call to_box(xi,yi,zi)
1690         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1691
1692 !
1693 ! Calculate SC interaction energy.
1694 !
1695         do iint=1,nint_gr(i)
1696           do j=istart(i,iint),iend(i,iint)
1697             itypj=iabs(itype(j,1))
1698             if (itypj.eq.ntyp1) cycle
1699             xj=c(1,nres+j)-xi
1700             yj=c(2,nres+j)-yi
1701             zj=c(3,nres+j)-zi
1702             call to_box(xj,yj,zj)
1703             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1704             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1705              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1706             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1707              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1708             xj=boxshift(xj-xi,boxxsize)
1709             yj=boxshift(yj-yi,boxysize)
1710             zj=boxshift(zj-zi,boxzsize)
1711             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1712             fac_augm=rrij**expon
1713             e_augm=augm(itypi,itypj)*fac_augm
1714             r_inv_ij=dsqrt(rrij)
1715             rij=1.0D0/r_inv_ij
1716             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1717             fac=r_shift_inv**expon
1718             e1=fac*fac*aa_aq(itypi,itypj)
1719             e2=fac*bb_aq(itypi,itypj)
1720             evdwij=e_augm+e1+e2
1721 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1722 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1723 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1724 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1725 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1726 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1727 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1728             evdw=evdw+evdwij
1729 !
1730 ! Calculate the components of the gradient in DC and X
1731 !
1732             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1733             gg(1)=xj*fac
1734             gg(2)=yj*fac
1735             gg(3)=zj*fac
1736             do k=1,3
1737               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1738               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1739               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1740               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1741             enddo
1742 !grad            do k=i,j-1
1743 !grad              do l=1,3
1744 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1745 !grad              enddo
1746 !grad            enddo
1747           enddo      ! j
1748         enddo        ! iint
1749       enddo          ! i
1750       do i=1,nct
1751         do j=1,3
1752           gvdwc(j,i)=expon*gvdwc(j,i)
1753           gvdwx(j,i)=expon*gvdwx(j,i)
1754         enddo
1755       enddo
1756       return
1757       end subroutine eljk
1758 !-----------------------------------------------------------------------------
1759       subroutine ebp(evdw)
1760 !
1761 ! This subroutine calculates the interaction energy of nonbonded side chains
1762 ! assuming the Berne-Pechukas potential of interaction.
1763 !
1764       use comm_srutu
1765       use calc_data
1766 !      implicit real*8 (a-h,o-z)
1767 !      include 'DIMENSIONS'
1768 !      include 'COMMON.GEO'
1769 !      include 'COMMON.VAR'
1770 !      include 'COMMON.LOCAL'
1771 !      include 'COMMON.CHAIN'
1772 !      include 'COMMON.DERIV'
1773 !      include 'COMMON.NAMES'
1774 !      include 'COMMON.INTERACT'
1775 !      include 'COMMON.IOUNITS'
1776 !      include 'COMMON.CALC'
1777       use comm_srutu
1778 !el      integer :: icall
1779 !el      common /srutu/ icall
1780 !     double precision rrsave(maxdim)
1781       logical :: lprn
1782 !el local variables
1783       integer :: iint,itypi,itypi1,itypj
1784       real(kind=8) :: rrij,xi,yi,zi, sslipi,ssgradlipi, sslipj, &
1785         ssgradlipj, aa, bb
1786       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1787
1788 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1789       evdw=0.0D0
1790 !     if (icall.eq.0) then
1791 !       lprn=.true.
1792 !     else
1793         lprn=.false.
1794 !     endif
1795 !el      ind=0
1796       do i=iatsc_s,iatsc_e
1797         itypi=iabs(itype(i,1))
1798         if (itypi.eq.ntyp1) cycle
1799         itypi1=iabs(itype(i+1,1))
1800         xi=c(1,nres+i)
1801         yi=c(2,nres+i)
1802         zi=c(3,nres+i)
1803         call to_box(xi,yi,zi)
1804         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1805         dxi=dc_norm(1,nres+i)
1806         dyi=dc_norm(2,nres+i)
1807         dzi=dc_norm(3,nres+i)
1808 !        dsci_inv=dsc_inv(itypi)
1809         dsci_inv=vbld_inv(i+nres)
1810 !
1811 ! Calculate SC interaction energy.
1812 !
1813         do iint=1,nint_gr(i)
1814           do j=istart(i,iint),iend(i,iint)
1815 !el            ind=ind+1
1816             itypj=iabs(itype(j,1))
1817             if (itypj.eq.ntyp1) cycle
1818 !            dscj_inv=dsc_inv(itypj)
1819             dscj_inv=vbld_inv(j+nres)
1820             chi1=chi(itypi,itypj)
1821             chi2=chi(itypj,itypi)
1822             chi12=chi1*chi2
1823             chip1=chip(itypi)
1824             chip2=chip(itypj)
1825             chip12=chip1*chip2
1826             alf1=alp(itypi)
1827             alf2=alp(itypj)
1828             alf12=0.5D0*(alf1+alf2)
1829 ! For diagnostics only!!!
1830 !           chi1=0.0D0
1831 !           chi2=0.0D0
1832 !           chi12=0.0D0
1833 !           chip1=0.0D0
1834 !           chip2=0.0D0
1835 !           chip12=0.0D0
1836 !           alf1=0.0D0
1837 !           alf2=0.0D0
1838 !           alf12=0.0D0
1839             xj=c(1,nres+j)-xi
1840             yj=c(2,nres+j)-yi
1841             zj=c(3,nres+j)-zi
1842             call to_box(xj,yj,zj)
1843             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1844             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1845              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1846             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1847              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1848             xj=boxshift(xj-xi,boxxsize)
1849             yj=boxshift(yj-yi,boxysize)
1850             zj=boxshift(zj-zi,boxzsize)
1851             dxj=dc_norm(1,nres+j)
1852             dyj=dc_norm(2,nres+j)
1853             dzj=dc_norm(3,nres+j)
1854             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1855 !d          if (icall.eq.0) then
1856 !d            rrsave(ind)=rrij
1857 !d          else
1858 !d            rrij=rrsave(ind)
1859 !d          endif
1860             rij=dsqrt(rrij)
1861 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1862             call sc_angular
1863 ! Calculate whole angle-dependent part of epsilon and contributions
1864 ! to its derivatives
1865             fac=(rrij*sigsq)**expon2
1866             e1=fac*fac*aa_aq(itypi,itypj)
1867             e2=fac*bb_aq(itypi,itypj)
1868             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1869             eps2der=evdwij*eps3rt
1870             eps3der=evdwij*eps2rt
1871             evdwij=evdwij*eps2rt*eps3rt
1872             evdw=evdw+evdwij
1873             if (lprn) then
1874             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1875             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1876 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1877 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1878 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1879 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1880 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1881 !d     &        evdwij
1882             endif
1883 ! Calculate gradient components.
1884             e1=e1*eps1*eps2rt**2*eps3rt**2
1885             fac=-expon*(e1+evdwij)
1886             sigder=fac/sigsq
1887             fac=rrij*fac
1888 ! Calculate radial part of the gradient
1889             gg(1)=xj*fac
1890             gg(2)=yj*fac
1891             gg(3)=zj*fac
1892 ! Calculate the angular part of the gradient and sum add the contributions
1893 ! to the appropriate components of the Cartesian gradient.
1894             call sc_grad
1895           enddo      ! j
1896         enddo        ! iint
1897       enddo          ! i
1898 !     stop
1899       return
1900       end subroutine ebp
1901 !-----------------------------------------------------------------------------
1902       subroutine egb(evdw)
1903 !
1904 ! This subroutine calculates the interaction energy of nonbonded side chains
1905 ! assuming the Gay-Berne potential of interaction.
1906 !
1907       use calc_data
1908 !      implicit real*8 (a-h,o-z)
1909 !      include 'DIMENSIONS'
1910 !      include 'COMMON.GEO'
1911 !      include 'COMMON.VAR'
1912 !      include 'COMMON.LOCAL'
1913 !      include 'COMMON.CHAIN'
1914 !      include 'COMMON.DERIV'
1915 !      include 'COMMON.NAMES'
1916 !      include 'COMMON.INTERACT'
1917 !      include 'COMMON.IOUNITS'
1918 !      include 'COMMON.CALC'
1919 !      include 'COMMON.CONTROL'
1920 !      include 'COMMON.SBRIDGE'
1921       logical :: lprn
1922 !el local variables
1923       integer :: iint,itypi,itypi1,itypj,subchap,icont
1924       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1925       real(kind=8) :: evdw,sig0ij
1926       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1927                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1928                     sslipi,sslipj,faclip
1929       integer :: ii
1930       real(kind=8) :: fracinbuf
1931
1932 !cccc      energy_dec=.false.
1933 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1934       evdw=0.0D0
1935       lprn=.false.
1936 !     if (icall.eq.0) lprn=.false.
1937 !el      ind=0
1938       dCAVdOM2=0.0d0
1939       dGCLdOM2=0.0d0
1940       dPOLdOM2=0.0d0
1941       dCAVdOM1=0.0d0
1942       dGCLdOM1=0.0d0
1943       dPOLdOM1=0.0d0
1944 !             write (iout,*) "RWA", g_listscsc_start,g_listscsc_end,i,j
1945       if (nres_molec(1).eq.0) return
1946       do icont=g_listscsc_start,g_listscsc_end
1947       i=newcontlisti(icont)
1948       j=newcontlistj(icont)
1949 !      write (iout,*) "RWA", g_listscsc_start,g_listscsc_end,i,j
1950 !      do i=iatsc_s,iatsc_e
1951 !C        print *,"I am in EVDW",i
1952         itypi=iabs(itype(i,1))
1953 !        if (i.ne.47) cycle
1954         if (itypi.eq.ntyp1) cycle
1955         itypi1=iabs(itype(i+1,1))
1956         xi=c(1,nres+i)
1957         yi=c(2,nres+i)
1958         zi=c(3,nres+i)
1959         call to_box(xi,yi,zi)
1960         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1961
1962         dxi=dc_norm(1,nres+i)
1963         dyi=dc_norm(2,nres+i)
1964         dzi=dc_norm(3,nres+i)
1965 !        dsci_inv=dsc_inv(itypi)
1966         dsci_inv=vbld_inv(i+nres)
1967 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1968 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1969 !
1970 ! Calculate SC interaction energy.
1971 !
1972 !        do iint=1,nint_gr(i)
1973 !          do j=istart(i,iint),iend(i,iint)
1974             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1975               call dyn_ssbond_ene(i,j,evdwij)
1976               evdw=evdw+evdwij
1977               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1978                               'evdw',i,j,evdwij,' ss'
1979 !              if (energy_dec) write (iout,*) &
1980 !                              'evdw',i,j,evdwij,' ss'
1981              do k=j+1,nres
1982 !C search over all next residues
1983               if (dyn_ss_mask(k)) then
1984 !C check if they are cysteins
1985 !C              write(iout,*) 'k=',k
1986
1987 !c              write(iout,*) "PRZED TRI", evdwij
1988 !               evdwij_przed_tri=evdwij
1989               call triple_ssbond_ene(i,j,k,evdwij)
1990 !c               if(evdwij_przed_tri.ne.evdwij) then
1991 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1992 !c               endif
1993
1994 !c              write(iout,*) "PO TRI", evdwij
1995 !C call the energy function that removes the artifical triple disulfide
1996 !C bond the soubroutine is located in ssMD.F
1997               evdw=evdw+evdwij
1998               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1999                             'evdw',i,j,evdwij,'tss'
2000               endif!dyn_ss_mask(k)
2001              enddo! k
2002             ELSE
2003 !el            ind=ind+1
2004             itypj=iabs(itype(j,1))
2005             if (itypj.eq.ntyp1) cycle
2006 !             if (j.ne.78) cycle
2007 !            dscj_inv=dsc_inv(itypj)
2008             dscj_inv=vbld_inv(j+nres)
2009 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
2010 !              1.0d0/vbld(j+nres) !d
2011 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
2012             sig0ij=sigma(itypi,itypj)
2013             chi1=chi(itypi,itypj)
2014             chi2=chi(itypj,itypi)
2015             chi12=chi1*chi2
2016             chip1=chip(itypi)
2017             chip2=chip(itypj)
2018             chip12=chip1*chip2
2019             alf1=alp(itypi)
2020             alf2=alp(itypj)
2021             alf12=0.5D0*(alf1+alf2)
2022 ! For diagnostics only!!!
2023 !           chi1=0.0D0
2024 !           chi2=0.0D0
2025 !           chi12=0.0D0
2026 !           chip1=0.0D0
2027 !           chip2=0.0D0
2028 !           chip12=0.0D0
2029 !           alf1=0.0D0
2030 !           alf2=0.0D0
2031 !           alf12=0.0D0
2032            xj=c(1,nres+j)
2033            yj=c(2,nres+j)
2034            zj=c(3,nres+j)
2035               call to_box(xj,yj,zj)
2036               call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2037 !              write (iout,*) "KWA2", itypi,itypj
2038               aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2039                +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2040               bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2041                +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2042               xj=boxshift(xj-xi,boxxsize)
2043               yj=boxshift(yj-yi,boxysize)
2044               zj=boxshift(zj-zi,boxzsize)
2045             dxj=dc_norm(1,nres+j)
2046             dyj=dc_norm(2,nres+j)
2047             dzj=dc_norm(3,nres+j)
2048 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2049 !            write (iout,*) "j",j," dc_norm",& !d
2050 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2051 !          write(iout,*)"rrij ",rrij
2052 !          write(iout,*)"xj yj zj ", xj, yj, zj
2053 !          write(iout,*)"xi yi zi ", xi, yi, zi
2054 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
2055             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2056             rij=dsqrt(rrij)
2057             sss_ele_cut=sscale_ele(1.0d0/(rij))
2058             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
2059 !            print *,sss_ele_cut,sss_ele_grad,&
2060 !            1.0d0/(rij),r_cut_ele,rlamb_ele
2061             if (sss_ele_cut.le.0.0) cycle
2062 ! Calculate angle-dependent terms of energy and contributions to their
2063 ! derivatives.
2064             call sc_angular
2065             sigsq=1.0D0/sigsq
2066             sig=sig0ij*dsqrt(sigsq)
2067             rij_shift=1.0D0/rij-sig+sig0ij
2068 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
2069 !            "sig0ij",sig0ij
2070 ! for diagnostics; uncomment
2071 !            rij_shift=1.2*sig0ij
2072 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2073             if (rij_shift.le.0.0D0) then
2074               evdw=1.0D20
2075 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2076 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
2077 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2078               return
2079             endif
2080             sigder=-sig*sigsq
2081 !---------------------------------------------------------------
2082             rij_shift=1.0D0/rij_shift
2083             fac=rij_shift**expon
2084             faclip=fac
2085             e1=fac*fac*aa!(itypi,itypj)
2086             e2=fac*bb!(itypi,itypj)
2087             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2088             eps2der=evdwij*eps3rt
2089             eps3der=evdwij*eps2rt
2090 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
2091 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
2092 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
2093             evdwij=evdwij*eps2rt*eps3rt
2094             evdw=evdw+evdwij*sss_ele_cut
2095             if (lprn) then
2096             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2097             epsi=bb**2/aa!(itypi,itypj)
2098             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2099               restyp(itypi,1),i,restyp(itypj,1),j, &
2100               epsi,sigm,chi1,chi2,chip1,chip2, &
2101               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
2102               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
2103               evdwij
2104             endif
2105
2106             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
2107                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
2108 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
2109 !            if (energy_dec) write (iout,*) &
2110 !                             'evdw',i,j,evdwij
2111 !                       print *,"ZALAMKA", evdw
2112
2113 ! Calculate gradient components.
2114             e1=e1*eps1*eps2rt**2*eps3rt**2
2115             fac=-expon*(e1+evdwij)*rij_shift
2116             sigder=fac*sigder
2117             fac=rij*fac
2118 !            print *,'before fac',fac,rij,evdwij
2119             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
2120             *rij
2121 !            print *,'grad part scale',fac,   &
2122 !             evdwij*sss_ele_grad/sss_ele_cut &
2123 !            /sigma(itypi,itypj)*rij
2124 !            fac=0.0d0
2125 ! Calculate the radial part of the gradient
2126             gg(1)=xj*fac
2127             gg(2)=yj*fac
2128             gg(3)=zj*fac
2129 !C Calculate the radial part of the gradient
2130             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
2131        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
2132         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
2133        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2134             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2135             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2136
2137 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
2138 ! Calculate angular part of the gradient.
2139             call sc_grad
2140             ENDIF    ! dyn_ss
2141 !          enddo      ! j
2142 !        enddo        ! iint
2143       enddo          ! i
2144 !       print *,"ZALAMKA", evdw
2145 !      write (iout,*) "Number of loop steps in EGB:",ind
2146 !ccc      energy_dec=.false.
2147       return
2148       end subroutine egb
2149 !-----------------------------------------------------------------------------
2150       subroutine egbv(evdw)
2151 !
2152 ! This subroutine calculates the interaction energy of nonbonded side chains
2153 ! assuming the Gay-Berne-Vorobjev potential of interaction.
2154 !
2155       use comm_srutu
2156       use calc_data
2157 !      implicit real*8 (a-h,o-z)
2158 !      include 'DIMENSIONS'
2159 !      include 'COMMON.GEO'
2160 !      include 'COMMON.VAR'
2161 !      include 'COMMON.LOCAL'
2162 !      include 'COMMON.CHAIN'
2163 !      include 'COMMON.DERIV'
2164 !      include 'COMMON.NAMES'
2165 !      include 'COMMON.INTERACT'
2166 !      include 'COMMON.IOUNITS'
2167 !      include 'COMMON.CALC'
2168       use comm_srutu
2169 !el      integer :: icall
2170 !el      common /srutu/ icall
2171       logical :: lprn
2172 !el local variables
2173       integer :: iint,itypi,itypi1,itypj
2174       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2, &
2175          sigm,sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb
2176       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
2177
2178 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2179       evdw=0.0D0
2180       lprn=.false.
2181 !     if (icall.eq.0) lprn=.true.
2182 !el      ind=0
2183       do i=iatsc_s,iatsc_e
2184         itypi=iabs(itype(i,1))
2185         if (itypi.eq.ntyp1) cycle
2186         itypi1=iabs(itype(i+1,1))
2187         xi=c(1,nres+i)
2188         yi=c(2,nres+i)
2189         zi=c(3,nres+i)
2190         call to_box(xi,yi,zi)
2191         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2192         dxi=dc_norm(1,nres+i)
2193         dyi=dc_norm(2,nres+i)
2194         dzi=dc_norm(3,nres+i)
2195 !        dsci_inv=dsc_inv(itypi)
2196         dsci_inv=vbld_inv(i+nres)
2197 !
2198 ! Calculate SC interaction energy.
2199 !
2200         do iint=1,nint_gr(i)
2201           do j=istart(i,iint),iend(i,iint)
2202 !el            ind=ind+1
2203             itypj=iabs(itype(j,1))
2204             if (itypj.eq.ntyp1) cycle
2205 !            dscj_inv=dsc_inv(itypj)
2206             dscj_inv=vbld_inv(j+nres)
2207             sig0ij=sigma(itypi,itypj)
2208             r0ij=r0(itypi,itypj)
2209             chi1=chi(itypi,itypj)
2210             chi2=chi(itypj,itypi)
2211             chi12=chi1*chi2
2212             chip1=chip(itypi)
2213             chip2=chip(itypj)
2214             chip12=chip1*chip2
2215             alf1=alp(itypi)
2216             alf2=alp(itypj)
2217             alf12=0.5D0*(alf1+alf2)
2218 ! For diagnostics only!!!
2219 !           chi1=0.0D0
2220 !           chi2=0.0D0
2221 !           chi12=0.0D0
2222 !           chip1=0.0D0
2223 !           chip2=0.0D0
2224 !           chip12=0.0D0
2225 !           alf1=0.0D0
2226 !           alf2=0.0D0
2227 !           alf12=0.0D0
2228             xj=c(1,nres+j)-xi
2229             yj=c(2,nres+j)-yi
2230             zj=c(3,nres+j)-zi
2231            call to_box(xj,yj,zj)
2232            call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2233            aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2234             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2235            bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2236             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2237            xj=boxshift(xj-xi,boxxsize)
2238            yj=boxshift(yj-yi,boxysize)
2239            zj=boxshift(zj-zi,boxzsize)
2240             dxj=dc_norm(1,nres+j)
2241             dyj=dc_norm(2,nres+j)
2242             dzj=dc_norm(3,nres+j)
2243             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2244             rij=dsqrt(rrij)
2245 ! Calculate angle-dependent terms of energy and contributions to their
2246 ! derivatives.
2247             call sc_angular
2248             sigsq=1.0D0/sigsq
2249             sig=sig0ij*dsqrt(sigsq)
2250             rij_shift=1.0D0/rij-sig+r0ij
2251 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2252             if (rij_shift.le.0.0D0) then
2253               evdw=1.0D20
2254               return
2255             endif
2256             sigder=-sig*sigsq
2257 !---------------------------------------------------------------
2258             rij_shift=1.0D0/rij_shift
2259             fac=rij_shift**expon
2260             e1=fac*fac*aa_aq(itypi,itypj)
2261             e2=fac*bb_aq(itypi,itypj)
2262             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2263             eps2der=evdwij*eps3rt
2264             eps3der=evdwij*eps2rt
2265             fac_augm=rrij**expon
2266             e_augm=augm(itypi,itypj)*fac_augm
2267             evdwij=evdwij*eps2rt*eps3rt
2268             evdw=evdw+evdwij+e_augm
2269             if (lprn) then
2270             sigm=dabs(aa_aq(itypi,itypj)/&
2271             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2272             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2273             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2274               restyp(itypi,1),i,restyp(itypj,1),j,&
2275               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2276               chi1,chi2,chip1,chip2,&
2277               eps1,eps2rt**2,eps3rt**2,&
2278               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2279               evdwij+e_augm
2280             endif
2281 ! Calculate gradient components.
2282             e1=e1*eps1*eps2rt**2*eps3rt**2
2283             fac=-expon*(e1+evdwij)*rij_shift
2284             sigder=fac*sigder
2285             fac=rij*fac-2*expon*rrij*e_augm
2286 ! Calculate the radial part of the gradient
2287             gg(1)=xj*fac
2288             gg(2)=yj*fac
2289             gg(3)=zj*fac
2290 ! Calculate angular part of the gradient.
2291             call sc_grad
2292           enddo      ! j
2293         enddo        ! iint
2294       enddo          ! i
2295       end subroutine egbv
2296 !-----------------------------------------------------------------------------
2297 !el      subroutine sc_angular in module geometry
2298 !-----------------------------------------------------------------------------
2299       subroutine e_softsphere(evdw)
2300 !
2301 ! This subroutine calculates the interaction energy of nonbonded side chains
2302 ! assuming the LJ potential of interaction.
2303 !
2304 !      implicit real*8 (a-h,o-z)
2305 !      include 'DIMENSIONS'
2306       real(kind=8),parameter :: accur=1.0d-10
2307 !      include 'COMMON.GEO'
2308 !      include 'COMMON.VAR'
2309 !      include 'COMMON.LOCAL'
2310 !      include 'COMMON.CHAIN'
2311 !      include 'COMMON.DERIV'
2312 !      include 'COMMON.INTERACT'
2313 !      include 'COMMON.TORSION'
2314 !      include 'COMMON.SBRIDGE'
2315 !      include 'COMMON.NAMES'
2316 !      include 'COMMON.IOUNITS'
2317 !      include 'COMMON.CONTACTS'
2318       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2319 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2320 !el local variables
2321       integer :: i,iint,j,itypi,itypi1,itypj,k
2322       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2323       real(kind=8) :: fac
2324
2325       evdw=0.0D0
2326       do i=iatsc_s,iatsc_e
2327         itypi=iabs(itype(i,1))
2328         if (itypi.eq.ntyp1) cycle
2329         itypi1=iabs(itype(i+1,1))
2330         xi=c(1,nres+i)
2331         yi=c(2,nres+i)
2332         zi=c(3,nres+i)
2333         call to_box(xi,yi,zi)
2334
2335 !
2336 ! Calculate SC interaction energy.
2337 !
2338         do iint=1,nint_gr(i)
2339 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2340 !d   &                  'iend=',iend(i,iint)
2341           do j=istart(i,iint),iend(i,iint)
2342             itypj=iabs(itype(j,1))
2343             if (itypj.eq.ntyp1) cycle
2344             xj=boxshift(c(1,nres+j)-xi,boxxsize)
2345             yj=boxshift(c(2,nres+j)-yi,boxysize)
2346             zj=boxshift(c(3,nres+j)-zi,boxzsize)
2347             rij=xj*xj+yj*yj+zj*zj
2348 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2349             r0ij=r0(itypi,itypj)
2350             r0ijsq=r0ij*r0ij
2351 !            print *,i,j,r0ij,dsqrt(rij)
2352             if (rij.lt.r0ijsq) then
2353               evdwij=0.25d0*(rij-r0ijsq)**2
2354               fac=rij-r0ijsq
2355             else
2356               evdwij=0.0d0
2357               fac=0.0d0
2358             endif
2359             evdw=evdw+evdwij
2360 !
2361 ! Calculate the components of the gradient in DC and X
2362 !
2363             gg(1)=xj*fac
2364             gg(2)=yj*fac
2365             gg(3)=zj*fac
2366             do k=1,3
2367               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2368               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2369               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2370               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2371             enddo
2372 !grad            do k=i,j-1
2373 !grad              do l=1,3
2374 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2375 !grad              enddo
2376 !grad            enddo
2377           enddo ! j
2378         enddo ! iint
2379       enddo ! i
2380       return
2381       end subroutine e_softsphere
2382 !-----------------------------------------------------------------------------
2383       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2384 !
2385 ! Soft-sphere potential of p-p interaction
2386 !
2387 !      implicit real*8 (a-h,o-z)
2388 !      include 'DIMENSIONS'
2389 !      include 'COMMON.CONTROL'
2390 !      include 'COMMON.IOUNITS'
2391 !      include 'COMMON.GEO'
2392 !      include 'COMMON.VAR'
2393 !      include 'COMMON.LOCAL'
2394 !      include 'COMMON.CHAIN'
2395 !      include 'COMMON.DERIV'
2396 !      include 'COMMON.INTERACT'
2397 !      include 'COMMON.CONTACTS'
2398 !      include 'COMMON.TORSION'
2399 !      include 'COMMON.VECTORS'
2400 !      include 'COMMON.FFIELD'
2401       real(kind=8),dimension(3) :: ggg
2402 !d      write(iout,*) 'In EELEC_soft_sphere'
2403 !el local variables
2404       integer :: i,j,k,num_conti,iteli,itelj
2405       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2406       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2407       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2408
2409       ees=0.0D0
2410       evdw1=0.0D0
2411       eel_loc=0.0d0
2412       eello_turn3=0.0d0
2413       eello_turn4=0.0d0
2414 !el      ind=0
2415       do i=iatel_s,iatel_e
2416         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2417         dxi=dc(1,i)
2418         dyi=dc(2,i)
2419         dzi=dc(3,i)
2420         xmedi=c(1,i)+0.5d0*dxi
2421         ymedi=c(2,i)+0.5d0*dyi
2422         zmedi=c(3,i)+0.5d0*dzi
2423         call to_box(xmedi,ymedi,zmedi)
2424         num_conti=0
2425 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2426         do j=ielstart(i),ielend(i)
2427           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2428 !el          ind=ind+1
2429           iteli=itel(i)
2430           itelj=itel(j)
2431           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2432           r0ij=rpp(iteli,itelj)
2433           r0ijsq=r0ij*r0ij
2434           dxj=dc(1,j)
2435           dyj=dc(2,j)
2436           dzj=dc(3,j)
2437           xj=c(1,j)+0.5D0*dxj-xmedi
2438           yj=c(2,j)+0.5D0*dyj-ymedi
2439           zj=c(3,j)+0.5D0*dzj-zmedi
2440           call to_box(xj,yj,zj)
2441           xj=boxshift(xj-xmedi,boxxsize)
2442           yj=boxshift(yj-ymedi,boxysize)
2443           zj=boxshift(zj-zmedi,boxzsize)
2444           rij=xj*xj+yj*yj+zj*zj
2445           if (rij.lt.r0ijsq) then
2446             evdw1ij=0.25d0*(rij-r0ijsq)**2
2447             fac=rij-r0ijsq
2448           else
2449             evdw1ij=0.0d0
2450             fac=0.0d0
2451           endif
2452           evdw1=evdw1+evdw1ij
2453 !
2454 ! Calculate contributions to the Cartesian gradient.
2455 !
2456           ggg(1)=fac*xj
2457           ggg(2)=fac*yj
2458           ggg(3)=fac*zj
2459           do k=1,3
2460             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2461             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2462           enddo
2463 !
2464 ! Loop over residues i+1 thru j-1.
2465 !
2466 !grad          do k=i+1,j-1
2467 !grad            do l=1,3
2468 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2469 !grad            enddo
2470 !grad          enddo
2471         enddo ! j
2472       enddo   ! i
2473 !grad      do i=nnt,nct-1
2474 !grad        do k=1,3
2475 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2476 !grad        enddo
2477 !grad        do j=i+1,nct-1
2478 !grad          do k=1,3
2479 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2480 !grad          enddo
2481 !grad        enddo
2482 !grad      enddo
2483       return
2484       end subroutine eelec_soft_sphere
2485 !-----------------------------------------------------------------------------
2486       subroutine vec_and_deriv
2487 !      implicit real*8 (a-h,o-z)
2488 !      include 'DIMENSIONS'
2489 #ifdef MPI
2490       include 'mpif.h'
2491 #endif
2492 !      include 'COMMON.IOUNITS'
2493 !      include 'COMMON.GEO'
2494 !      include 'COMMON.VAR'
2495 !      include 'COMMON.LOCAL'
2496 !      include 'COMMON.CHAIN'
2497 !      include 'COMMON.VECTORS'
2498 !      include 'COMMON.SETUP'
2499 !      include 'COMMON.TIME1'
2500       real(kind=8),dimension(3,3,2) :: uyder,uzder
2501       real(kind=8),dimension(2) :: vbld_inv_temp
2502 ! Compute the local reference systems. For reference system (i), the
2503 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2504 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2505 !el local variables
2506       integer :: i,j,k,l
2507       real(kind=8) :: facy,fac,costh
2508
2509 #ifdef PARVEC
2510       do i=ivec_start,ivec_end
2511 #else
2512       do i=1,nres-1
2513 #endif
2514           if (i.eq.nres-1) then
2515 ! Case of the last full residue
2516 ! Compute the Z-axis
2517             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2518             costh=dcos(pi-theta(nres))
2519             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2520             do k=1,3
2521               uz(k,i)=fac*uz(k,i)
2522             enddo
2523 ! Compute the derivatives of uz
2524             uzder(1,1,1)= 0.0d0
2525             uzder(2,1,1)=-dc_norm(3,i-1)
2526             uzder(3,1,1)= dc_norm(2,i-1)
2527             uzder(1,2,1)= dc_norm(3,i-1)
2528             uzder(2,2,1)= 0.0d0
2529             uzder(3,2,1)=-dc_norm(1,i-1)
2530             uzder(1,3,1)=-dc_norm(2,i-1)
2531             uzder(2,3,1)= dc_norm(1,i-1)
2532             uzder(3,3,1)= 0.0d0
2533             uzder(1,1,2)= 0.0d0
2534             uzder(2,1,2)= dc_norm(3,i)
2535             uzder(3,1,2)=-dc_norm(2,i)
2536             uzder(1,2,2)=-dc_norm(3,i)
2537             uzder(2,2,2)= 0.0d0
2538             uzder(3,2,2)= dc_norm(1,i)
2539             uzder(1,3,2)= dc_norm(2,i)
2540             uzder(2,3,2)=-dc_norm(1,i)
2541             uzder(3,3,2)= 0.0d0
2542 ! Compute the Y-axis
2543             facy=fac
2544             do k=1,3
2545               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2546             enddo
2547 ! Compute the derivatives of uy
2548             do j=1,3
2549               do k=1,3
2550                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2551                               -dc_norm(k,i)*dc_norm(j,i-1)
2552                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2553               enddo
2554               uyder(j,j,1)=uyder(j,j,1)-costh
2555               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2556             enddo
2557             do j=1,2
2558               do k=1,3
2559                 do l=1,3
2560                   uygrad(l,k,j,i)=uyder(l,k,j)
2561                   uzgrad(l,k,j,i)=uzder(l,k,j)
2562                 enddo
2563               enddo
2564             enddo
2565             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2566             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2567             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2568             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2569           else
2570 ! Other residues
2571 ! Compute the Z-axis
2572             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2573             costh=dcos(pi-theta(i+2))
2574             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2575             do k=1,3
2576               uz(k,i)=fac*uz(k,i)
2577             enddo
2578 ! Compute the derivatives of uz
2579             uzder(1,1,1)= 0.0d0
2580             uzder(2,1,1)=-dc_norm(3,i+1)
2581             uzder(3,1,1)= dc_norm(2,i+1)
2582             uzder(1,2,1)= dc_norm(3,i+1)
2583             uzder(2,2,1)= 0.0d0
2584             uzder(3,2,1)=-dc_norm(1,i+1)
2585             uzder(1,3,1)=-dc_norm(2,i+1)
2586             uzder(2,3,1)= dc_norm(1,i+1)
2587             uzder(3,3,1)= 0.0d0
2588             uzder(1,1,2)= 0.0d0
2589             uzder(2,1,2)= dc_norm(3,i)
2590             uzder(3,1,2)=-dc_norm(2,i)
2591             uzder(1,2,2)=-dc_norm(3,i)
2592             uzder(2,2,2)= 0.0d0
2593             uzder(3,2,2)= dc_norm(1,i)
2594             uzder(1,3,2)= dc_norm(2,i)
2595             uzder(2,3,2)=-dc_norm(1,i)
2596             uzder(3,3,2)= 0.0d0
2597 ! Compute the Y-axis
2598             facy=fac
2599             do k=1,3
2600               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2601             enddo
2602 ! Compute the derivatives of uy
2603             do j=1,3
2604               do k=1,3
2605                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2606                               -dc_norm(k,i)*dc_norm(j,i+1)
2607                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2608               enddo
2609               uyder(j,j,1)=uyder(j,j,1)-costh
2610               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2611             enddo
2612             do j=1,2
2613               do k=1,3
2614                 do l=1,3
2615                   uygrad(l,k,j,i)=uyder(l,k,j)
2616                   uzgrad(l,k,j,i)=uzder(l,k,j)
2617                 enddo
2618               enddo
2619             enddo
2620             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2621             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2622             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2623             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2624           endif
2625       enddo
2626       do i=1,nres-1
2627         vbld_inv_temp(1)=vbld_inv(i+1)
2628         if (i.lt.nres-1) then
2629           vbld_inv_temp(2)=vbld_inv(i+2)
2630           else
2631           vbld_inv_temp(2)=vbld_inv(i)
2632           endif
2633         do j=1,2
2634           do k=1,3
2635             do l=1,3
2636               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2637               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2638             enddo
2639           enddo
2640         enddo
2641       enddo
2642 #if defined(PARVEC) && defined(MPI)
2643       if (nfgtasks1.gt.1) then
2644         time00=MPI_Wtime()
2645 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2646 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2647 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2648         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2649          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2650          FG_COMM1,IERR)
2651         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2652          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2653          FG_COMM1,IERR)
2654         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2655          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2656          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2657         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2658          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2659          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2660         time_gather=time_gather+MPI_Wtime()-time00
2661       endif
2662 !      if (fg_rank.eq.0) then
2663 !        write (iout,*) "Arrays UY and UZ"
2664 !        do i=1,nres-1
2665 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2666 !     &     (uz(k,i),k=1,3)
2667 !        enddo
2668 !      endif
2669 #endif
2670       return
2671       end subroutine vec_and_deriv
2672 !-----------------------------------------------------------------------------
2673       subroutine check_vecgrad
2674 !      implicit real*8 (a-h,o-z)
2675 !      include 'DIMENSIONS'
2676 !      include 'COMMON.IOUNITS'
2677 !      include 'COMMON.GEO'
2678 !      include 'COMMON.VAR'
2679 !      include 'COMMON.LOCAL'
2680 !      include 'COMMON.CHAIN'
2681 !      include 'COMMON.VECTORS'
2682       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2683       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2684       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2685       real(kind=8),dimension(3) :: erij
2686       real(kind=8) :: delta=1.0d-7
2687 !el local variables
2688       integer :: i,j,k,l
2689
2690       call vec_and_deriv
2691 !d      do i=1,nres
2692 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2693 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2694 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2695 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2696 !d     &     (dc_norm(if90,i),if90=1,3)
2697 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2698 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2699 !d          write(iout,'(a)')
2700 !d      enddo
2701       do i=1,nres
2702         do j=1,2
2703           do k=1,3
2704             do l=1,3
2705               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2706               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2707             enddo
2708           enddo
2709         enddo
2710       enddo
2711       call vec_and_deriv
2712       do i=1,nres
2713         do j=1,3
2714           uyt(j,i)=uy(j,i)
2715           uzt(j,i)=uz(j,i)
2716         enddo
2717       enddo
2718       do i=1,nres
2719 !d        write (iout,*) 'i=',i
2720         do k=1,3
2721           erij(k)=dc_norm(k,i)
2722         enddo
2723         do j=1,3
2724           do k=1,3
2725             dc_norm(k,i)=erij(k)
2726           enddo
2727           dc_norm(j,i)=dc_norm(j,i)+delta
2728 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2729 !          do k=1,3
2730 !            dc_norm(k,i)=dc_norm(k,i)/fac
2731 !          enddo
2732 !          write (iout,*) (dc_norm(k,i),k=1,3)
2733 !          write (iout,*) (erij(k),k=1,3)
2734           call vec_and_deriv
2735           do k=1,3
2736             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2737             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2738             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2739             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2740           enddo
2741 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2742 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2743 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2744         enddo
2745         do k=1,3
2746           dc_norm(k,i)=erij(k)
2747         enddo
2748 !d        do k=1,3
2749 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2750 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2751 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2752 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2753 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2754 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2755 !d          write (iout,'(a)')
2756 !d        enddo
2757       enddo
2758       return
2759       end subroutine check_vecgrad
2760 !-----------------------------------------------------------------------------
2761       subroutine set_matrices
2762 !      implicit real*8 (a-h,o-z)
2763 !      include 'DIMENSIONS'
2764 #ifdef MPI
2765       include "mpif.h"
2766 !      include "COMMON.SETUP"
2767       integer :: IERR
2768       integer :: status(MPI_STATUS_SIZE)
2769 #endif
2770 !      include 'COMMON.IOUNITS'
2771 !      include 'COMMON.GEO'
2772 !      include 'COMMON.VAR'
2773 !      include 'COMMON.LOCAL'
2774 !      include 'COMMON.CHAIN'
2775 !      include 'COMMON.DERIV'
2776 !      include 'COMMON.INTERACT'
2777 !      include 'COMMON.CONTACTS'
2778 !      include 'COMMON.TORSION'
2779 !      include 'COMMON.VECTORS'
2780 !      include 'COMMON.FFIELD'
2781       real(kind=8) :: auxvec(2),auxmat(2,2)
2782       integer :: i,iti1,iti,k,l
2783       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2,cost1,sint1,&
2784        sint1sq,sint1cub,sint1cost1,b1k,b2k,aux
2785 !       print *,"in set matrices"
2786 !
2787 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2788 ! to calculate the el-loc multibody terms of various order.
2789 !
2790 !AL el      mu=0.0d0
2791
2792 #ifdef PARMAT
2793       do i=ivec_start+2,ivec_end+2
2794 #else
2795       do i=3,nres+1
2796 #endif
2797         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2798           if (itype(i-2,1).eq.0) then
2799           iti = nloctyp
2800           else
2801           iti = itype2loc(itype(i-2,1))
2802           endif
2803         else
2804           iti=nloctyp
2805         endif
2806 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2807         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2808           iti1 = itype2loc(itype(i-1,1))
2809         else
2810           iti1=nloctyp
2811         endif
2812 !        print *,i,itype(i-2,1),iti
2813 #ifdef NEWCORR
2814         cost1=dcos(theta(i-1))
2815         sint1=dsin(theta(i-1))
2816         sint1sq=sint1*sint1
2817         sint1cub=sint1sq*sint1
2818         sint1cost1=2*sint1*cost1
2819 !        print *,"cost1",cost1,theta(i-1)
2820 !c        write (iout,*) "bnew1",i,iti
2821 !c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2822 !c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2823 !c        write (iout,*) "bnew2",i,iti
2824 !c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2825 !c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2826         k=1
2827 !        print *,bnew1(1,k,iti),"bnew1"
2828         do k=1,2
2829           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2830 !          print *,b1k
2831 !          write(*,*) shape(b1)
2832 !          if(.not.allocated(b1)) print *, "WTF?"
2833           b1(k,i-2)=sint1*b1k
2834 !
2835 !             print *,b1(k,i-2)
2836
2837           gtb1(k,i-2)=cost1*b1k-sint1sq*&
2838                    (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2839 !             print *,gtb1(k,i-2)
2840
2841           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2842           b2(k,i-2)=sint1*b2k
2843 !             print *,b2(k,i-2)
2844
2845           gtb2(k,i-2)=cost1*b2k-sint1sq*&
2846                    (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2847 !             print *,gtb2(k,i-2)
2848
2849         enddo
2850 !        print *,b1k,b2k
2851         do k=1,2
2852           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2853           cc(1,k,i-2)=sint1sq*aux
2854           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*&
2855                    (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2856           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2857           dd(1,k,i-2)=sint1sq*aux
2858           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*&
2859                    (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2860         enddo
2861 !        print *,"after cc"
2862         cc(2,1,i-2)=cc(1,2,i-2)
2863         cc(2,2,i-2)=-cc(1,1,i-2)
2864         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2865         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2866         dd(2,1,i-2)=dd(1,2,i-2)
2867         dd(2,2,i-2)=-dd(1,1,i-2)
2868         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2869         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2870 !        print *,"after dd"
2871
2872         do k=1,2
2873           do l=1,2
2874             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2875             EE(l,k,i-2)=sint1sq*aux
2876             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2877           enddo
2878         enddo
2879         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2880         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2881         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2882         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2883         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2884         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2885         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2886 !        print *,"after ee"
2887
2888 !c        b1tilde(1,i-2)=b1(1,i-2)
2889 !c        b1tilde(2,i-2)=-b1(2,i-2)
2890 !c        b2tilde(1,i-2)=b2(1,i-2)
2891 !c        b2tilde(2,i-2)=-b2(2,i-2)
2892 #ifdef DEBUG
2893         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2894         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2895         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2896         write (iout,*) 'theta=', theta(i-1)
2897 #endif
2898 #else
2899         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2900 !         write(iout,*) "i,",molnum(i),nloctyp
2901 !         print *, "i,",molnum(i),i,itype(i-2,1)
2902         if (molnum(i).eq.1) then
2903           if (itype(i-2,1).eq.ntyp1) then
2904            iti=nloctyp
2905           else
2906           iti = itype2loc(itype(i-2,1))
2907           endif
2908         else
2909           iti=nloctyp
2910         endif
2911         else
2912           iti=nloctyp
2913         endif
2914 !c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2915 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2916         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2917           iti1 = itype2loc(itype(i-1,1))
2918         else
2919           iti1=nloctyp
2920         endif
2921 !        print *,i,iti
2922         b1(1,i-2)=b(3,iti)
2923         b1(2,i-2)=b(5,iti)
2924         b2(1,i-2)=b(2,iti)
2925         b2(2,i-2)=b(4,iti)
2926         do k=1,2
2927           do l=1,2
2928            CC(k,l,i-2)=ccold(k,l,iti)
2929            DD(k,l,i-2)=ddold(k,l,iti)
2930            EE(k,l,i-2)=eeold(k,l,iti)
2931           enddo
2932         enddo
2933 #endif
2934         b1tilde(1,i-2)= b1(1,i-2)
2935         b1tilde(2,i-2)=-b1(2,i-2)
2936         b2tilde(1,i-2)= b2(1,i-2)
2937         b2tilde(2,i-2)=-b2(2,i-2)
2938 !c
2939         Ctilde(1,1,i-2)= CC(1,1,i-2)
2940         Ctilde(1,2,i-2)= CC(1,2,i-2)
2941         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2942         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2943 !c
2944         Dtilde(1,1,i-2)= DD(1,1,i-2)
2945         Dtilde(1,2,i-2)= DD(1,2,i-2)
2946         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2947         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2948       enddo
2949 #ifdef PARMAT
2950       do i=ivec_start+2,ivec_end+2
2951 #else
2952       do i=3,nres+1
2953 #endif
2954
2955 !      print *,i,"i"
2956         if (i .lt. nres+1) then
2957           sin1=dsin(phi(i))
2958           cos1=dcos(phi(i))
2959           sintab(i-2)=sin1
2960           costab(i-2)=cos1
2961           obrot(1,i-2)=cos1
2962           obrot(2,i-2)=sin1
2963           sin2=dsin(2*phi(i))
2964           cos2=dcos(2*phi(i))
2965           sintab2(i-2)=sin2
2966           costab2(i-2)=cos2
2967           obrot2(1,i-2)=cos2
2968           obrot2(2,i-2)=sin2
2969           Ug(1,1,i-2)=-cos1
2970           Ug(1,2,i-2)=-sin1
2971           Ug(2,1,i-2)=-sin1
2972           Ug(2,2,i-2)= cos1
2973           Ug2(1,1,i-2)=-cos2
2974           Ug2(1,2,i-2)=-sin2
2975           Ug2(2,1,i-2)=-sin2
2976           Ug2(2,2,i-2)= cos2
2977         else
2978           costab(i-2)=1.0d0
2979           sintab(i-2)=0.0d0
2980           obrot(1,i-2)=1.0d0
2981           obrot(2,i-2)=0.0d0
2982           obrot2(1,i-2)=0.0d0
2983           obrot2(2,i-2)=0.0d0
2984           Ug(1,1,i-2)=1.0d0
2985           Ug(1,2,i-2)=0.0d0
2986           Ug(2,1,i-2)=0.0d0
2987           Ug(2,2,i-2)=1.0d0
2988           Ug2(1,1,i-2)=0.0d0
2989           Ug2(1,2,i-2)=0.0d0
2990           Ug2(2,1,i-2)=0.0d0
2991           Ug2(2,2,i-2)=0.0d0
2992         endif
2993         if (i .gt. 3 .and. i .lt. nres+1) then
2994           obrot_der(1,i-2)=-sin1
2995           obrot_der(2,i-2)= cos1
2996           Ugder(1,1,i-2)= sin1
2997           Ugder(1,2,i-2)=-cos1
2998           Ugder(2,1,i-2)=-cos1
2999           Ugder(2,2,i-2)=-sin1
3000           dwacos2=cos2+cos2
3001           dwasin2=sin2+sin2
3002           obrot2_der(1,i-2)=-dwasin2
3003           obrot2_der(2,i-2)= dwacos2
3004           Ug2der(1,1,i-2)= dwasin2
3005           Ug2der(1,2,i-2)=-dwacos2
3006           Ug2der(2,1,i-2)=-dwacos2
3007           Ug2der(2,2,i-2)=-dwasin2
3008         else
3009           obrot_der(1,i-2)=0.0d0
3010           obrot_der(2,i-2)=0.0d0
3011           Ugder(1,1,i-2)=0.0d0
3012           Ugder(1,2,i-2)=0.0d0
3013           Ugder(2,1,i-2)=0.0d0
3014           Ugder(2,2,i-2)=0.0d0
3015           obrot2_der(1,i-2)=0.0d0
3016           obrot2_der(2,i-2)=0.0d0
3017           Ug2der(1,1,i-2)=0.0d0
3018           Ug2der(1,2,i-2)=0.0d0
3019           Ug2der(2,1,i-2)=0.0d0
3020           Ug2der(2,2,i-2)=0.0d0
3021         endif
3022 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3023         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3024            if (itype(i-2,1).eq.0) then
3025           iti=ntortyp+1
3026            else
3027           iti = itype2loc(itype(i-2,1))
3028            endif
3029         else
3030           iti=nloctyp
3031         endif
3032 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3033         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3034            if (itype(i-1,1).eq.0) then
3035           iti1=nloctyp
3036            else
3037           iti1 = itype2loc(itype(i-1,1))
3038            endif
3039         else
3040           iti1=nloctyp
3041         endif
3042 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
3043 !d        write (iout,*) '*******i',i,' iti1',iti
3044 !        write (iout,*) 'b1',b1(:,iti)
3045 !        write (iout,*) 'b2',b2(:,i-2)
3046 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
3047 !        if (i .gt. iatel_s+2) then
3048         if (i .gt. nnt+2) then
3049           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3050 #ifdef NEWCORR
3051           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3052 !c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3053 #endif
3054
3055           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3056           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3057           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3058           then
3059           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3060           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3061           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3062           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3063           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3064           endif
3065         else
3066           do k=1,2
3067             Ub2(k,i-2)=0.0d0
3068             Ctobr(k,i-2)=0.0d0
3069             Dtobr2(k,i-2)=0.0d0
3070             do l=1,2
3071               EUg(l,k,i-2)=0.0d0
3072               CUg(l,k,i-2)=0.0d0
3073               DUg(l,k,i-2)=0.0d0
3074               DtUg2(l,k,i-2)=0.0d0
3075             enddo
3076           enddo
3077         endif
3078         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3079         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3080         do k=1,2
3081           muder(k,i-2)=Ub2der(k,i-2)
3082         enddo
3083 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3084         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3085           if (itype(i-1,1).eq.0) then
3086            iti1=nloctyp
3087           elseif (itype(i-1,1).le.ntyp) then
3088             iti1 = itype2loc(itype(i-1,1))
3089           else
3090             iti1=nloctyp
3091           endif
3092         else
3093           iti1=nloctyp
3094         endif
3095         do k=1,2
3096           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3097         enddo
3098         if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
3099         if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,i-1)
3100         if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
3101 !d        write (iout,*) 'mu1',mu1(:,i-2)
3102 !d        write (iout,*) 'mu2',mu2(:,i-2)
3103         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3104         then
3105         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3106         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3107         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3108         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3109         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3110 ! Vectors and matrices dependent on a single virtual-bond dihedral.
3111         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3112         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3113         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3114         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3115         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3116         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3117         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3118         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3119         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3120         endif
3121       enddo
3122 ! Matrices dependent on two consecutive virtual-bond dihedrals.
3123 ! The order of matrices is from left to right.
3124       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3125       then
3126 !      do i=max0(ivec_start,2),ivec_end
3127       do i=2,nres-1
3128         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3129         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3130         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3131         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3132         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3133         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3134         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3135         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3136       enddo
3137       endif
3138 #if defined(MPI) && defined(PARMAT)
3139 #ifdef DEBUG
3140 !      if (fg_rank.eq.0) then
3141         write (iout,*) "Arrays UG and UGDER before GATHER"
3142         do i=1,nres-1
3143           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3144            ((ug(l,k,i),l=1,2),k=1,2),&
3145            ((ugder(l,k,i),l=1,2),k=1,2)
3146         enddo
3147         write (iout,*) "Arrays UG2 and UG2DER"
3148         do i=1,nres-1
3149           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3150            ((ug2(l,k,i),l=1,2),k=1,2),&
3151            ((ug2der(l,k,i),l=1,2),k=1,2)
3152         enddo
3153         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3154         do i=1,nres-1
3155           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3156            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3157            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3158         enddo
3159         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3160         do i=1,nres-1
3161           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3162            costab(i),sintab(i),costab2(i),sintab2(i)
3163         enddo
3164         write (iout,*) "Array MUDER"
3165         do i=1,nres-1
3166           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3167         enddo
3168 !      endif
3169 #endif
3170       if (nfgtasks.gt.1) then
3171         time00=MPI_Wtime()
3172 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3173 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3174 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3175 #ifdef MATGATHER
3176         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
3177          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3178          FG_COMM1,IERR)
3179         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
3180          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3181          FG_COMM1,IERR)
3182         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
3183          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3184          FG_COMM1,IERR)
3185         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
3186          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3187          FG_COMM1,IERR)
3188         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
3189          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3190          FG_COMM1,IERR)
3191         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
3192          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3193          FG_COMM1,IERR)
3194         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
3195          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
3196          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3197         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
3198          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
3199          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3200         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
3201          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
3202          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3203         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
3204          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
3205          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3206         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3207         then
3208         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
3209          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3210          FG_COMM1,IERR)
3211         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
3212          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3213          FG_COMM1,IERR)
3214         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
3215          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3216          FG_COMM1,IERR)
3217        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
3218          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3219          FG_COMM1,IERR)
3220         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
3221          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3222          FG_COMM1,IERR)
3223         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
3224          ivec_count(fg_rank1),&
3225          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3226          FG_COMM1,IERR)
3227         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
3228          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3229          FG_COMM1,IERR)
3230         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
3231          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3232          FG_COMM1,IERR)
3233         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
3234          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3235          FG_COMM1,IERR)
3236         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
3237          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3238          FG_COMM1,IERR)
3239         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
3240          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3241          FG_COMM1,IERR)
3242         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
3243          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3244          FG_COMM1,IERR)
3245         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
3246          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3247          FG_COMM1,IERR)
3248         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
3249          ivec_count(fg_rank1),&
3250          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3251          FG_COMM1,IERR)
3252         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
3253          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3254          FG_COMM1,IERR)
3255        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
3256          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3257          FG_COMM1,IERR)
3258         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
3259          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3260          FG_COMM1,IERR)
3261        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
3262          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3263          FG_COMM1,IERR)
3264         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
3265          ivec_count(fg_rank1),&
3266          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3267          FG_COMM1,IERR)
3268         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
3269          ivec_count(fg_rank1),&
3270          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3271          FG_COMM1,IERR)
3272         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
3273          ivec_count(fg_rank1),&
3274          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3275          MPI_MAT2,FG_COMM1,IERR)
3276         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
3277          ivec_count(fg_rank1),&
3278          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3279          MPI_MAT2,FG_COMM1,IERR)
3280         endif
3281 #else
3282 ! Passes matrix info through the ring
3283       isend=fg_rank1
3284       irecv=fg_rank1-1
3285       if (irecv.lt.0) irecv=nfgtasks1-1
3286       iprev=irecv
3287       inext=fg_rank1+1
3288       if (inext.ge.nfgtasks1) inext=0
3289       do i=1,nfgtasks1-1
3290 !        write (iout,*) "isend",isend," irecv",irecv
3291 !        call flush(iout)
3292         lensend=lentyp(isend)
3293         lenrecv=lentyp(irecv)
3294 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3295 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3296 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
3297 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3298 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
3299 !        write (iout,*) "Gather ROTAT1"
3300 !        call flush(iout)
3301 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3302 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
3303 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3304 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
3305 !        write (iout,*) "Gather ROTAT2"
3306 !        call flush(iout)
3307         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
3308          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
3309          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
3310          iprev,4400+irecv,FG_COMM,status,IERR)
3311 !        write (iout,*) "Gather ROTAT_OLD"
3312 !        call flush(iout)
3313         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
3314          MPI_PRECOMP11(lensend),inext,5500+isend,&
3315          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
3316          iprev,5500+irecv,FG_COMM,status,IERR)
3317 !        write (iout,*) "Gather PRECOMP11"
3318 !        call flush(iout)
3319         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
3320          MPI_PRECOMP12(lensend),inext,6600+isend,&
3321          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
3322          iprev,6600+irecv,FG_COMM,status,IERR)
3323 !        write (iout,*) "Gather PRECOMP12"
3324 !        call flush(iout)
3325         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3326         then
3327         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
3328          MPI_ROTAT2(lensend),inext,7700+isend,&
3329          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
3330          iprev,7700+irecv,FG_COMM,status,IERR)
3331 !        write (iout,*) "Gather PRECOMP21"
3332 !        call flush(iout)
3333         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
3334          MPI_PRECOMP22(lensend),inext,8800+isend,&
3335          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
3336          iprev,8800+irecv,FG_COMM,status,IERR)
3337 !        write (iout,*) "Gather PRECOMP22"
3338 !        call flush(iout)
3339         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
3340          MPI_PRECOMP23(lensend),inext,9900+isend,&
3341          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
3342          MPI_PRECOMP23(lenrecv),&
3343          iprev,9900+irecv,FG_COMM,status,IERR)
3344 !        write (iout,*) "Gather PRECOMP23"
3345 !        call flush(iout)
3346         endif
3347         isend=irecv
3348         irecv=irecv-1
3349         if (irecv.lt.0) irecv=nfgtasks1-1
3350       enddo
3351 #endif
3352         time_gather=time_gather+MPI_Wtime()-time00
3353       endif
3354 #ifdef DEBUG
3355 !      if (fg_rank.eq.0) then
3356         write (iout,*) "Arrays UG and UGDER"
3357         do i=1,nres-1
3358           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3359            ((ug(l,k,i),l=1,2),k=1,2),&
3360            ((ugder(l,k,i),l=1,2),k=1,2)
3361         enddo
3362         write (iout,*) "Arrays UG2 and UG2DER"
3363         do i=1,nres-1
3364           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3365            ((ug2(l,k,i),l=1,2),k=1,2),&
3366            ((ug2der(l,k,i),l=1,2),k=1,2)
3367         enddo
3368         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3369         do i=1,nres-1
3370           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3371            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3372            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3373         enddo
3374         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3375         do i=1,nres-1
3376           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3377            costab(i),sintab(i),costab2(i),sintab2(i)
3378         enddo
3379         write (iout,*) "Array MUDER"
3380         do i=1,nres-1
3381           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3382         enddo
3383 !      endif
3384 #endif
3385 #endif
3386 !d      do i=1,nres
3387 !d        iti = itortyp(itype(i,1))
3388 !d        write (iout,*) i
3389 !d        do j=1,2
3390 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3391 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3392 !d        enddo
3393 !d      enddo
3394       return
3395       end subroutine set_matrices
3396 !-----------------------------------------------------------------------------
3397       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3398 !
3399 ! This subroutine calculates the average interaction energy and its gradient
3400 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
3401 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3402 ! The potential depends both on the distance of peptide-group centers and on
3403 ! the orientation of the CA-CA virtual bonds.
3404 !
3405       use comm_locel
3406 !      implicit real*8 (a-h,o-z)
3407 #ifdef MPI
3408       include 'mpif.h'
3409 #endif
3410 !      include 'DIMENSIONS'
3411 !      include 'COMMON.CONTROL'
3412 !      include 'COMMON.SETUP'
3413 !      include 'COMMON.IOUNITS'
3414 !      include 'COMMON.GEO'
3415 !      include 'COMMON.VAR'
3416 !      include 'COMMON.LOCAL'
3417 !      include 'COMMON.CHAIN'
3418 !      include 'COMMON.DERIV'
3419 !      include 'COMMON.INTERACT'
3420 !      include 'COMMON.CONTACTS'
3421 !      include 'COMMON.TORSION'
3422 !      include 'COMMON.VECTORS'
3423 !      include 'COMMON.FFIELD'
3424 !      include 'COMMON.TIME1'
3425       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
3426       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3427       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3428 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3429       real(kind=8),dimension(4) :: muij
3430 !el      integer :: num_conti,j1,j2
3431 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3432 !el        dz_normi,xmedi,ymedi,zmedi
3433
3434 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3435 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3436 !el          num_conti,j1,j2
3437
3438 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3439 #ifdef MOMENT
3440       real(kind=8) :: scal_el=1.0d0
3441 #else
3442       real(kind=8) :: scal_el=0.5d0
3443 #endif
3444 ! 12/13/98
3445 ! 13-go grudnia roku pamietnego...
3446       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3447                                              0.0d0,1.0d0,0.0d0,&
3448                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3449 !el local variables
3450       integer :: i,k,j,icont
3451       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3452       real(kind=8) :: fac,t_eelecij,fracinbuf
3453
3454
3455 !d      write(iout,*) 'In EELEC'
3456 !        print *,"IN EELEC"
3457 !d      do i=1,nloctyp
3458 !d        write(iout,*) 'Type',i
3459 !d        write(iout,*) 'B1',B1(:,i)
3460 !d        write(iout,*) 'B2',B2(:,i)
3461 !d        write(iout,*) 'CC',CC(:,:,i)
3462 !d        write(iout,*) 'DD',DD(:,:,i)
3463 !d        write(iout,*) 'EE',EE(:,:,i)
3464 !d      enddo
3465 !d      call check_vecgrad
3466 !d      stop
3467 !      ees=0.0d0  !AS
3468 !      evdw1=0.0d0
3469 !      eel_loc=0.0d0
3470 !      eello_turn3=0.0d0
3471 !      eello_turn4=0.0d0
3472       t_eelecij=0.0d0
3473       ees=0.0D0
3474       evdw1=0.0D0
3475       eel_loc=0.0d0
3476       eello_turn3=0.0d0
3477       eello_turn4=0.0d0
3478       if (nres_molec(1).eq.0) return
3479 !
3480
3481       if (icheckgrad.eq.1) then
3482 !el
3483 !        do i=0,2*nres+2
3484 !          dc_norm(1,i)=0.0d0
3485 !          dc_norm(2,i)=0.0d0
3486 !          dc_norm(3,i)=0.0d0
3487 !        enddo
3488         do i=1,nres-1
3489           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3490           do k=1,3
3491             dc_norm(k,i)=dc(k,i)*fac
3492           enddo
3493 !          write (iout,*) 'i',i,' fac',fac
3494         enddo
3495       endif
3496 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3497 !        wturn6
3498       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3499           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3500           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3501 !        call vec_and_deriv
3502 #ifdef TIMING
3503         time01=MPI_Wtime()
3504 #endif
3505 !        print *, "before set matrices"
3506         call set_matrices
3507 !        print *, "after set matrices"
3508
3509 #ifdef TIMING
3510         time_mat=time_mat+MPI_Wtime()-time01
3511 #endif
3512       endif
3513 !       print *, "after set matrices"
3514 !d      do i=1,nres-1
3515 !d        write (iout,*) 'i=',i
3516 !d        do k=1,3
3517 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3518 !d        enddo
3519 !d        do k=1,3
3520 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3521 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3522 !d        enddo
3523 !d      enddo
3524       t_eelecij=0.0d0
3525       ees=0.0D0
3526       evdw1=0.0D0
3527       eel_loc=0.0d0
3528       eello_turn3=0.0d0
3529       eello_turn4=0.0d0
3530 !el      ind=0
3531       do i=1,nres
3532         num_cont_hb(i)=0
3533       enddo
3534 !d      print '(a)','Enter EELEC'
3535 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3536 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3537 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3538       do i=1,nres
3539         gel_loc_loc(i)=0.0d0
3540         gcorr_loc(i)=0.0d0
3541       enddo
3542 !
3543 !
3544 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3545 !
3546 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3547 !
3548
3549
3550 !        print *,"before iturn3 loop"
3551       do i=iturn3_start,iturn3_end
3552         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3553         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3554         dxi=dc(1,i)
3555         dyi=dc(2,i)
3556         dzi=dc(3,i)
3557         dx_normi=dc_norm(1,i)
3558         dy_normi=dc_norm(2,i)
3559         dz_normi=dc_norm(3,i)
3560         xmedi=c(1,i)+0.5d0*dxi
3561         ymedi=c(2,i)+0.5d0*dyi
3562         zmedi=c(3,i)+0.5d0*dzi
3563         call to_box(xmedi,ymedi,zmedi)
3564         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3565         num_conti=0
3566        call eelecij(i,i+2,ees,evdw1,eel_loc)
3567         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3568         num_cont_hb(i)=num_conti
3569       enddo
3570       do i=iturn4_start,iturn4_end
3571         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3572           .or. itype(i+3,1).eq.ntyp1 &
3573           .or. itype(i+4,1).eq.ntyp1) cycle
3574 !        print *,"before2",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3575         dxi=dc(1,i)
3576         dyi=dc(2,i)
3577         dzi=dc(3,i)
3578         dx_normi=dc_norm(1,i)
3579         dy_normi=dc_norm(2,i)
3580         dz_normi=dc_norm(3,i)
3581         xmedi=c(1,i)+0.5d0*dxi
3582         ymedi=c(2,i)+0.5d0*dyi
3583         zmedi=c(3,i)+0.5d0*dzi
3584         call to_box(xmedi,ymedi,zmedi)
3585         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3586         num_conti=num_cont_hb(i)
3587         call eelecij(i,i+3,ees,evdw1,eel_loc)
3588         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3589         call eturn4(i,eello_turn4)
3590 !        print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3591         num_cont_hb(i)=num_conti
3592       enddo   ! i
3593 !
3594 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3595 !
3596 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3597 !      do i=iatel_s,iatel_e
3598 ! JPRDLC
3599        do icont=g_listpp_start,g_listpp_end
3600         i=newcontlistppi(icont)
3601         j=newcontlistppj(icont)
3602         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3603         dxi=dc(1,i)
3604         dyi=dc(2,i)
3605         dzi=dc(3,i)
3606         dx_normi=dc_norm(1,i)
3607         dy_normi=dc_norm(2,i)
3608         dz_normi=dc_norm(3,i)
3609         xmedi=c(1,i)+0.5d0*dxi
3610         ymedi=c(2,i)+0.5d0*dyi
3611         zmedi=c(3,i)+0.5d0*dzi
3612         call to_box(xmedi,ymedi,zmedi)
3613         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3614
3615 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3616         num_conti=num_cont_hb(i)
3617 !        do j=ielstart(i),ielend(i)
3618 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3619           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3620           call eelecij(i,j,ees,evdw1,eel_loc)
3621 !        enddo ! j
3622         num_cont_hb(i)=num_conti
3623       enddo   ! i
3624 !      write (iout,*) "Number of loop steps in EELEC:",ind
3625 !d      do i=1,nres
3626 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3627 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3628 !d      enddo
3629 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3630 !cc      eel_loc=eel_loc+eello_turn3
3631 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3632       return
3633       end subroutine eelec
3634 !-----------------------------------------------------------------------------
3635       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3636
3637       use comm_locel
3638 !      implicit real*8 (a-h,o-z)
3639 !      include 'DIMENSIONS'
3640 #ifdef MPI
3641       include "mpif.h"
3642 #endif
3643 !      include 'COMMON.CONTROL'
3644 !      include 'COMMON.IOUNITS'
3645 !      include 'COMMON.GEO'
3646 !      include 'COMMON.VAR'
3647 !      include 'COMMON.LOCAL'
3648 !      include 'COMMON.CHAIN'
3649 !      include 'COMMON.DERIV'
3650 !      include 'COMMON.INTERACT'
3651 !      include 'COMMON.CONTACTS'
3652 !      include 'COMMON.TORSION'
3653 !      include 'COMMON.VECTORS'
3654 !      include 'COMMON.FFIELD'
3655 !      include 'COMMON.TIME1'
3656       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3657       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3658       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3659 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3660       real(kind=8),dimension(4) :: muij
3661       real(kind=8) :: geel_loc_ij,geel_loc_ji
3662       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3663                     dist_temp, dist_init,rlocshield,fracinbuf
3664       integer xshift,yshift,zshift,ilist,iresshield
3665 !el      integer :: num_conti,j1,j2
3666 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3667 !el        dz_normi,xmedi,ymedi,zmedi
3668
3669 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3670 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3671 !el          num_conti,j1,j2
3672
3673 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3674 #ifdef MOMENT
3675       real(kind=8) :: scal_el=1.0d0
3676 #else
3677       real(kind=8) :: scal_el=0.5d0
3678 #endif
3679 ! 12/13/98
3680 ! 13-go grudnia roku pamietnego...
3681       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3682                                              0.0d0,1.0d0,0.0d0,&
3683                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3684 !      integer :: maxconts=nres/4
3685 !el local variables
3686       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3687       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3688       real(kind=8) ::  faclipij2, faclipij
3689       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3690       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3691                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3692                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3693                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3694                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3695                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3696                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3697                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3698 !      maxconts=nres/4
3699 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3700 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3701
3702 !          time00=MPI_Wtime()
3703 !d      write (iout,*) "eelecij",i,j
3704 !          ind=ind+1
3705           iteli=itel(i)
3706           itelj=itel(j)
3707           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3708           aaa=app(iteli,itelj)
3709           bbb=bpp(iteli,itelj)
3710           ael6i=ael6(iteli,itelj)
3711           ael3i=ael3(iteli,itelj)
3712           dxj=dc(1,j)
3713           dyj=dc(2,j)
3714           dzj=dc(3,j)
3715           dx_normj=dc_norm(1,j)
3716           dy_normj=dc_norm(2,j)
3717           dz_normj=dc_norm(3,j)
3718 !          xj=c(1,j)+0.5D0*dxj-xmedi
3719 !          yj=c(2,j)+0.5D0*dyj-ymedi
3720 !          zj=c(3,j)+0.5D0*dzj-zmedi
3721           xj=c(1,j)+0.5D0*dxj
3722           yj=c(2,j)+0.5D0*dyj
3723           zj=c(3,j)+0.5D0*dzj
3724
3725           call to_box(xj,yj,zj)
3726           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
3727           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
3728           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3729           xj=boxshift(xj-xmedi,boxxsize)
3730           yj=boxshift(yj-ymedi,boxysize)
3731           zj=boxshift(zj-zmedi,boxzsize)
3732
3733           rij=xj*xj+yj*yj+zj*zj
3734           rrmij=1.0D0/rij
3735           rij=dsqrt(rij)
3736 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3737             sss_ele_cut=sscale_ele(rij)
3738             sss_ele_grad=sscagrad_ele(rij)
3739 !             sss_ele_cut=1.0d0
3740 !             sss_ele_grad=0.0d0
3741 !            print *,sss_ele_cut,sss_ele_grad,&
3742 !            (rij),r_cut_ele,rlamb_ele
3743             if (sss_ele_cut.le.0.0) go to 128
3744
3745           rmij=1.0D0/rij
3746           r3ij=rrmij*rmij
3747           r6ij=r3ij*r3ij
3748           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3749           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3750           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3751           fac=cosa-3.0D0*cosb*cosg
3752           ev1=aaa*r6ij*r6ij
3753 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3754           if (j.eq.i+2) ev1=scal_el*ev1
3755           ev2=bbb*r6ij
3756           fac3=ael6i*r6ij
3757           fac4=ael3i*r3ij
3758           evdwij=ev1+ev2
3759           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3760           el2=fac4*fac
3761 !          eesij=el1+el2
3762           if (shield_mode.gt.0) then
3763 !C          fac_shield(i)=0.4
3764 !C          fac_shield(j)=0.6
3765           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3766           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3767           eesij=(el1+el2)
3768           ees=ees+eesij*sss_ele_cut
3769 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3770 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3771           else
3772           fac_shield(i)=1.0
3773           fac_shield(j)=1.0
3774           eesij=(el1+el2)
3775           ees=ees+eesij   &
3776             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3777 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3778           endif
3779
3780 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3781           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3782 !          ees=ees+eesij*sss_ele_cut
3783           evdw1=evdw1+evdwij*sss_ele_cut  &
3784            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3785 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3786 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3787 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3788 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3789
3790           if (energy_dec) then
3791 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3792 !                  'evdw1',i,j,evdwij,&
3793 !                  iteli,itelj,aaa,evdw1
3794               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3795               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3796           endif
3797 !
3798 ! Calculate contributions to the Cartesian gradient.
3799 !
3800 #ifdef SPLITELE
3801           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3802               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3803           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3804              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3805           fac1=fac
3806           erij(1)=xj*rmij
3807           erij(2)=yj*rmij
3808           erij(3)=zj*rmij
3809 !
3810 ! Radial derivatives. First process both termini of the fragment (i,j)
3811 !
3812           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3813           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3814           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3815            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3816           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3817             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3818
3819           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3820           (shield_mode.gt.0)) then
3821 !C          print *,i,j
3822           do ilist=1,ishield_list(i)
3823            iresshield=shield_list(ilist,i)
3824            do k=1,3
3825            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3826            *2.0*sss_ele_cut
3827            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3828                    rlocshield &
3829             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3830             *sss_ele_cut
3831             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3832            enddo
3833           enddo
3834           do ilist=1,ishield_list(j)
3835            iresshield=shield_list(ilist,j)
3836            do k=1,3
3837            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3838           *2.0*sss_ele_cut
3839            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3840                    rlocshield &
3841            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3842            *sss_ele_cut
3843            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3844            enddo
3845           enddo
3846           do k=1,3
3847             gshieldc(k,i)=gshieldc(k,i)+ &
3848                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3849            *sss_ele_cut
3850
3851             gshieldc(k,j)=gshieldc(k,j)+ &
3852                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3853            *sss_ele_cut
3854
3855             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3856                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3857            *sss_ele_cut
3858
3859             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3860                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3861            *sss_ele_cut
3862
3863            enddo
3864            endif
3865
3866
3867 !          do k=1,3
3868 !            ghalf=0.5D0*ggg(k)
3869 !            gelc(k,i)=gelc(k,i)+ghalf
3870 !            gelc(k,j)=gelc(k,j)+ghalf
3871 !          enddo
3872 ! 9/28/08 AL Gradient compotents will be summed only at the end
3873           do k=1,3
3874             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3875             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3876           enddo
3877             gelc_long(3,j)=gelc_long(3,j)+  &
3878           ssgradlipj*eesij/2.0d0*lipscale**2&
3879            *sss_ele_cut
3880
3881             gelc_long(3,i)=gelc_long(3,i)+  &
3882           ssgradlipi*eesij/2.0d0*lipscale**2&
3883            *sss_ele_cut
3884
3885
3886 !
3887 ! Loop over residues i+1 thru j-1.
3888 !
3889 !grad          do k=i+1,j-1
3890 !grad            do l=1,3
3891 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3892 !grad            enddo
3893 !grad          enddo
3894           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3895            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3896           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3897            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3898           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3899            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3900
3901 !          do k=1,3
3902 !            ghalf=0.5D0*ggg(k)
3903 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3904 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3905 !          enddo
3906 ! 9/28/08 AL Gradient compotents will be summed only at the end
3907           do k=1,3
3908             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3909             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3910           enddo
3911
3912 !C Lipidic part for scaling weight
3913            gvdwpp(3,j)=gvdwpp(3,j)+ &
3914           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3915            gvdwpp(3,i)=gvdwpp(3,i)+ &
3916           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3917 !! Loop over residues i+1 thru j-1.
3918 !
3919 !grad          do k=i+1,j-1
3920 !grad            do l=1,3
3921 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3922 !grad            enddo
3923 !grad          enddo
3924 #else
3925           facvdw=(ev1+evdwij)*sss_ele_cut &
3926            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3927
3928           facel=(el1+eesij)*sss_ele_cut
3929           fac1=fac
3930           fac=-3*rrmij*(facvdw+facvdw+facel)
3931           erij(1)=xj*rmij
3932           erij(2)=yj*rmij
3933           erij(3)=zj*rmij
3934 !
3935 ! Radial derivatives. First process both termini of the fragment (i,j)
3936 !
3937           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3938           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3939           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3940 !          do k=1,3
3941 !            ghalf=0.5D0*ggg(k)
3942 !            gelc(k,i)=gelc(k,i)+ghalf
3943 !            gelc(k,j)=gelc(k,j)+ghalf
3944 !          enddo
3945 ! 9/28/08 AL Gradient compotents will be summed only at the end
3946           do k=1,3
3947             gelc_long(k,j)=gelc(k,j)+ggg(k)
3948             gelc_long(k,i)=gelc(k,i)-ggg(k)
3949           enddo
3950 !
3951 ! Loop over residues i+1 thru j-1.
3952 !
3953 !grad          do k=i+1,j-1
3954 !grad            do l=1,3
3955 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3956 !grad            enddo
3957 !grad          enddo
3958 ! 9/28/08 AL Gradient compotents will be summed only at the end
3959           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3960            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3961           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3962            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3963           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3964            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3965
3966           do k=1,3
3967             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3968             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3969           enddo
3970            gvdwpp(3,j)=gvdwpp(3,j)+ &
3971           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3972            gvdwpp(3,i)=gvdwpp(3,i)+ &
3973           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3974
3975 #endif
3976 !
3977 ! Angular part
3978 !
3979           ecosa=2.0D0*fac3*fac1+fac4
3980           fac4=-3.0D0*fac4
3981           fac3=-6.0D0*fac3
3982           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3983           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3984           do k=1,3
3985             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3986             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3987           enddo
3988 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3989 !d   &          (dcosg(k),k=1,3)
3990           do k=1,3
3991             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3992              *fac_shield(i)**2*fac_shield(j)**2 &
3993              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3994
3995           enddo
3996 !          do k=1,3
3997 !            ghalf=0.5D0*ggg(k)
3998 !            gelc(k,i)=gelc(k,i)+ghalf
3999 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4000 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4001 !            gelc(k,j)=gelc(k,j)+ghalf
4002 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4003 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4004 !          enddo
4005 !grad          do k=i+1,j-1
4006 !grad            do l=1,3
4007 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
4008 !grad            enddo
4009 !grad          enddo
4010           do k=1,3
4011             gelc(k,i)=gelc(k,i) &
4012                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4013                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
4014                      *sss_ele_cut &
4015                      *fac_shield(i)**2*fac_shield(j)**2 &
4016                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4017
4018             gelc(k,j)=gelc(k,j) &
4019                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4020                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4021                      *sss_ele_cut  &
4022                      *fac_shield(i)**2*fac_shield(j)**2  &
4023                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4024
4025             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4026             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4027           enddo
4028
4029           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
4030               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
4031               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4032 !
4033 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4034 !   energy of a peptide unit is assumed in the form of a second-order
4035 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4036 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4037 !   are computed for EVERY pair of non-contiguous peptide groups.
4038 !
4039           if (j.lt.nres-1) then
4040             j1=j+1
4041             j2=j-1
4042           else
4043             j1=j-1
4044             j2=j-2
4045           endif
4046           kkk=0
4047           do k=1,2
4048             do l=1,2
4049               kkk=kkk+1
4050               muij(kkk)=mu(k,i)*mu(l,j)
4051 #ifdef NEWCORR
4052              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4053 !c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4054              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4055              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4056 !c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4057              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4058 #endif
4059
4060             enddo
4061           enddo
4062 !d         write (iout,*) 'EELEC: i',i,' j',j
4063 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
4064 !d          write(iout,*) 'muij',muij
4065           ury=scalar(uy(1,i),erij)
4066           urz=scalar(uz(1,i),erij)
4067           vry=scalar(uy(1,j),erij)
4068           vrz=scalar(uz(1,j),erij)
4069           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4070           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4071           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4072           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4073           fac=dsqrt(-ael6i)*r3ij
4074           a22=a22*fac
4075           a23=a23*fac
4076           a32=a32*fac
4077           a33=a33*fac
4078 !d          write (iout,'(4i5,4f10.5)')
4079 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
4080 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4081 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4082 !d     &      uy(:,j),uz(:,j)
4083 !d          write (iout,'(4f10.5)')
4084 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4085 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4086 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
4087 !d           write (iout,'(9f10.5/)')
4088 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4089 ! Derivatives of the elements of A in virtual-bond vectors
4090           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4091           do k=1,3
4092             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4093             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4094             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4095             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4096             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4097             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4098             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4099             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4100             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4101             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4102             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4103             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4104           enddo
4105 ! Compute radial contributions to the gradient
4106           facr=-3.0d0*rrmij
4107           a22der=a22*facr
4108           a23der=a23*facr
4109           a32der=a32*facr
4110           a33der=a33*facr
4111           agg(1,1)=a22der*xj
4112           agg(2,1)=a22der*yj
4113           agg(3,1)=a22der*zj
4114           agg(1,2)=a23der*xj
4115           agg(2,2)=a23der*yj
4116           agg(3,2)=a23der*zj
4117           agg(1,3)=a32der*xj
4118           agg(2,3)=a32der*yj
4119           agg(3,3)=a32der*zj
4120           agg(1,4)=a33der*xj
4121           agg(2,4)=a33der*yj
4122           agg(3,4)=a33der*zj
4123 ! Add the contributions coming from er
4124           fac3=-3.0d0*fac
4125           do k=1,3
4126             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4127             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4128             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4129             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4130           enddo
4131           do k=1,3
4132 ! Derivatives in DC(i)
4133 !grad            ghalf1=0.5d0*agg(k,1)
4134 !grad            ghalf2=0.5d0*agg(k,2)
4135 !grad            ghalf3=0.5d0*agg(k,3)
4136 !grad            ghalf4=0.5d0*agg(k,4)
4137             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
4138             -3.0d0*uryg(k,2)*vry)!+ghalf1
4139             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
4140             -3.0d0*uryg(k,2)*vrz)!+ghalf2
4141             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
4142             -3.0d0*urzg(k,2)*vry)!+ghalf3
4143             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
4144             -3.0d0*urzg(k,2)*vrz)!+ghalf4
4145 ! Derivatives in DC(i+1)
4146             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
4147             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4148             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
4149             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4150             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
4151             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4152             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
4153             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4154 ! Derivatives in DC(j)
4155             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
4156             -3.0d0*vryg(k,2)*ury)!+ghalf1
4157             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
4158             -3.0d0*vrzg(k,2)*ury)!+ghalf2
4159             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
4160             -3.0d0*vryg(k,2)*urz)!+ghalf3
4161             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
4162             -3.0d0*vrzg(k,2)*urz)!+ghalf4
4163 ! Derivatives in DC(j+1) or DC(nres-1)
4164             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
4165             -3.0d0*vryg(k,3)*ury)
4166             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
4167             -3.0d0*vrzg(k,3)*ury)
4168             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
4169             -3.0d0*vryg(k,3)*urz)
4170             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
4171             -3.0d0*vrzg(k,3)*urz)
4172 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
4173 !grad              do l=1,4
4174 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4175 !grad              enddo
4176 !grad            endif
4177           enddo
4178           acipa(1,1)=a22
4179           acipa(1,2)=a23
4180           acipa(2,1)=a32
4181           acipa(2,2)=a33
4182           a22=-a22
4183           a23=-a23
4184           do l=1,2
4185             do k=1,3
4186               agg(k,l)=-agg(k,l)
4187               aggi(k,l)=-aggi(k,l)
4188               aggi1(k,l)=-aggi1(k,l)
4189               aggj(k,l)=-aggj(k,l)
4190               aggj1(k,l)=-aggj1(k,l)
4191             enddo
4192           enddo
4193           if (j.lt.nres-1) then
4194             a22=-a22
4195             a32=-a32
4196             do l=1,3,2
4197               do k=1,3
4198                 agg(k,l)=-agg(k,l)
4199                 aggi(k,l)=-aggi(k,l)
4200                 aggi1(k,l)=-aggi1(k,l)
4201                 aggj(k,l)=-aggj(k,l)
4202                 aggj1(k,l)=-aggj1(k,l)
4203               enddo
4204             enddo
4205           else
4206             a22=-a22
4207             a23=-a23
4208             a32=-a32
4209             a33=-a33
4210             do l=1,4
4211               do k=1,3
4212                 agg(k,l)=-agg(k,l)
4213                 aggi(k,l)=-aggi(k,l)
4214                 aggi1(k,l)=-aggi1(k,l)
4215                 aggj(k,l)=-aggj(k,l)
4216                 aggj1(k,l)=-aggj1(k,l)
4217               enddo
4218             enddo
4219           endif
4220           ENDIF ! WCORR
4221           IF (wel_loc.gt.0.0d0) THEN
4222 ! Contribution to the local-electrostatic energy coming from the i-j pair
4223           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
4224            +a33*muij(4)
4225           if (shield_mode.eq.0) then
4226            fac_shield(i)=1.0
4227            fac_shield(j)=1.0
4228           endif
4229           eel_loc_ij=eel_loc_ij &
4230          *fac_shield(i)*fac_shield(j) &
4231          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4232 !C Now derivative over eel_loc
4233           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
4234          (shield_mode.gt.0)) then
4235 !C          print *,i,j
4236
4237           do ilist=1,ishield_list(i)
4238            iresshield=shield_list(ilist,i)
4239            do k=1,3
4240            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
4241                                                 /fac_shield(i)&
4242            *sss_ele_cut
4243            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4244                    rlocshield  &
4245           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
4246           *sss_ele_cut
4247
4248             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4249            +rlocshield
4250            enddo
4251           enddo
4252           do ilist=1,ishield_list(j)
4253            iresshield=shield_list(ilist,j)
4254            do k=1,3
4255            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
4256                                             /fac_shield(j)   &
4257             *sss_ele_cut
4258            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4259                    rlocshield  &
4260       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
4261        *sss_ele_cut
4262
4263            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4264                   +rlocshield
4265
4266            enddo
4267           enddo
4268
4269           do k=1,3
4270             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
4271                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4272                     *sss_ele_cut
4273             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
4274                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4275                     *sss_ele_cut
4276             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
4277                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4278                     *sss_ele_cut
4279             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
4280                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4281                     *sss_ele_cut
4282
4283            enddo
4284            endif
4285
4286 #ifdef NEWCORR
4287          geel_loc_ij=(a22*gmuij1(1)&
4288           +a23*gmuij1(2)&
4289           +a32*gmuij1(3)&
4290           +a33*gmuij1(4))&
4291          *fac_shield(i)*fac_shield(j)&
4292                     *sss_ele_cut     &
4293          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4294
4295
4296 !c         write(iout,*) "derivative over thatai"
4297 !c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4298 !c     &   a33*gmuij1(4)
4299          gloc(nphi+i,icg)=gloc(nphi+i,icg)+&
4300            geel_loc_ij*wel_loc
4301 !c         write(iout,*) "derivative over thatai-1"
4302 !c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4303 !c     &   a33*gmuij2(4)
4304          geel_loc_ij=&
4305           a22*gmuij2(1)&
4306           +a23*gmuij2(2)&
4307           +a32*gmuij2(3)&
4308           +a33*gmuij2(4)
4309          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+&
4310            geel_loc_ij*wel_loc&
4311          *fac_shield(i)*fac_shield(j)&
4312                     *sss_ele_cut &
4313          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4314
4315
4316 !c  Derivative over j residue
4317          geel_loc_ji=a22*gmuji1(1)&
4318           +a23*gmuji1(2)&
4319           +a32*gmuji1(3)&
4320           +a33*gmuji1(4)
4321 !c         write(iout,*) "derivative over thataj"
4322 !c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4323 !c     &   a33*gmuji1(4)
4324
4325         gloc(nphi+j,icg)=gloc(nphi+j,icg)+&
4326            geel_loc_ji*wel_loc&
4327          *fac_shield(i)*fac_shield(j)&
4328                     *sss_ele_cut &
4329          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4330
4331
4332          geel_loc_ji=&
4333           +a22*gmuji2(1)&
4334           +a23*gmuji2(2)&
4335           +a32*gmuji2(3)&
4336           +a33*gmuji2(4)
4337 !c         write(iout,*) "derivative over thataj-1"
4338 !c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4339 !c     &   a33*gmuji2(4)
4340          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+&
4341            geel_loc_ji*wel_loc&
4342          *fac_shield(i)*fac_shield(j)&
4343                     *sss_ele_cut &
4344          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4345
4346 #endif
4347
4348 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4349 !           eel_loc_ij=0.0
4350 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4351 !                  'eelloc',i,j,eel_loc_ij
4352           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
4353                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4354 !           print *,"EELLOC",i,gel_loc_loc(i-1)
4355
4356 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4357 !          if (energy_dec) write (iout,*) "muij",muij
4358 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
4359
4360           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
4361 ! Partial derivatives in virtual-bond dihedral angles gamma
4362           if (i.gt.1) &
4363           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
4364                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
4365                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
4366                  *sss_ele_cut  &
4367           *fac_shield(i)*fac_shield(j) &
4368           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4369
4370           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
4371                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
4372                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
4373                  *sss_ele_cut &
4374           *fac_shield(i)*fac_shield(j) &
4375           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4376 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4377 !          do l=1,3
4378 !            ggg(1)=(agg(1,1)*muij(1)+ &
4379 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
4380 !            *sss_ele_cut &
4381 !             +eel_loc_ij*sss_ele_grad*rmij*xj
4382 !            ggg(2)=(agg(2,1)*muij(1)+ &
4383 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4384 !            *sss_ele_cut &
4385 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4386 !            ggg(3)=(agg(3,1)*muij(1)+ &
4387 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4388 !            *sss_ele_cut &
4389 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4390            xtemp(1)=xj
4391            xtemp(2)=yj
4392            xtemp(3)=zj
4393
4394            do l=1,3
4395             ggg(l)=(agg(l,1)*muij(1)+ &
4396                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4397             *sss_ele_cut &
4398           *fac_shield(i)*fac_shield(j) &
4399           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4400              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4401
4402
4403             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4404             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4405 !grad            ghalf=0.5d0*ggg(l)
4406 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4407 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4408           enddo
4409             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4410           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4411           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4412
4413             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4414           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4415           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4416
4417 !grad          do k=i+1,j2
4418 !grad            do l=1,3
4419 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4420 !grad            enddo
4421 !grad          enddo
4422 ! Remaining derivatives of eello
4423           do l=1,3
4424             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4425                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4426             *sss_ele_cut &
4427           *fac_shield(i)*fac_shield(j) &
4428           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4429
4430 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4431             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4432                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4433             +aggi1(l,4)*muij(4))&
4434             *sss_ele_cut &
4435           *fac_shield(i)*fac_shield(j) &
4436           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4437
4438 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4439             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4440                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4441             *sss_ele_cut &
4442           *fac_shield(i)*fac_shield(j) &
4443           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4444
4445 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4446             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4447                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4448             +aggj1(l,4)*muij(4))&
4449             *sss_ele_cut &
4450           *fac_shield(i)*fac_shield(j) &
4451          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4452
4453 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4454           enddo
4455           ENDIF
4456 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4457 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4458           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4459              .and. num_conti.le.maxconts) then
4460 !            write (iout,*) i,j," entered corr"
4461 !
4462 ! Calculate the contact function. The ith column of the array JCONT will
4463 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4464 ! greater than I). The arrays FACONT and GACONT will contain the values of
4465 ! the contact function and its derivative.
4466 !           r0ij=1.02D0*rpp(iteli,itelj)
4467 !           r0ij=1.11D0*rpp(iteli,itelj)
4468             r0ij=2.20D0*rpp(iteli,itelj)
4469 !           r0ij=1.55D0*rpp(iteli,itelj)
4470             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4471 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4472             if (fcont.gt.0.0D0) then
4473               num_conti=num_conti+1
4474               if (num_conti.gt.maxconts) then
4475 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4476 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4477                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4478                                ' will skip next contacts for this conf.', num_conti
4479               else
4480                 jcont_hb(num_conti,i)=j
4481 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4482 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4483                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4484                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4485 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4486 !  terms.
4487                 d_cont(num_conti,i)=rij
4488 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4489 !     --- Electrostatic-interaction matrix ---
4490                 a_chuj(1,1,num_conti,i)=a22
4491                 a_chuj(1,2,num_conti,i)=a23
4492                 a_chuj(2,1,num_conti,i)=a32
4493                 a_chuj(2,2,num_conti,i)=a33
4494 !     --- Gradient of rij
4495                 do kkk=1,3
4496                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4497                 enddo
4498                 kkll=0
4499                 do k=1,2
4500                   do l=1,2
4501                     kkll=kkll+1
4502                     do m=1,3
4503                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4504                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4505                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4506                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4507                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4508                     enddo
4509                   enddo
4510                 enddo
4511                 ENDIF
4512                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4513 ! Calculate contact energies
4514                 cosa4=4.0D0*cosa
4515                 wij=cosa-3.0D0*cosb*cosg
4516                 cosbg1=cosb+cosg
4517                 cosbg2=cosb-cosg
4518 !               fac3=dsqrt(-ael6i)/r0ij**3
4519                 fac3=dsqrt(-ael6i)*r3ij
4520 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4521                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4522                 if (ees0tmp.gt.0) then
4523                   ees0pij=dsqrt(ees0tmp)
4524                 else
4525                   ees0pij=0
4526                 endif
4527                 if (shield_mode.eq.0) then
4528                 fac_shield(i)=1.0d0
4529                 fac_shield(j)=1.0d0
4530                 else
4531                 ees0plist(num_conti,i)=j
4532                 endif
4533 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4534                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4535                 if (ees0tmp.gt.0) then
4536                   ees0mij=dsqrt(ees0tmp)
4537                 else
4538                   ees0mij=0
4539                 endif
4540 !               ees0mij=0.0D0
4541                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4542                      *sss_ele_cut &
4543                      *fac_shield(i)*fac_shield(j)
4544 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4545
4546                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4547                      *sss_ele_cut &
4548                      *fac_shield(i)*fac_shield(j)
4549 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4550
4551 ! Diagnostics. Comment out or remove after debugging!
4552 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4553 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4554 !               ees0m(num_conti,i)=0.0D0
4555 ! End diagnostics.
4556 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4557 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4558 ! Angular derivatives of the contact function
4559                 ees0pij1=fac3/ees0pij
4560                 ees0mij1=fac3/ees0mij
4561                 fac3p=-3.0D0*fac3*rrmij
4562                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4563                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4564 !               ees0mij1=0.0D0
4565                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4566                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4567                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4568                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4569                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4570                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4571                 ecosap=ecosa1+ecosa2
4572                 ecosbp=ecosb1+ecosb2
4573                 ecosgp=ecosg1+ecosg2
4574                 ecosam=ecosa1-ecosa2
4575                 ecosbm=ecosb1-ecosb2
4576                 ecosgm=ecosg1-ecosg2
4577 ! Diagnostics
4578 !               ecosap=ecosa1
4579 !               ecosbp=ecosb1
4580 !               ecosgp=ecosg1
4581 !               ecosam=0.0D0
4582 !               ecosbm=0.0D0
4583 !               ecosgm=0.0D0
4584 ! End diagnostics
4585                 facont_hb(num_conti,i)=fcont
4586                 fprimcont=fprimcont/rij
4587 !d              facont_hb(num_conti,i)=1.0D0
4588 ! Following line is for diagnostics.
4589 !d              fprimcont=0.0D0
4590                 do k=1,3
4591                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4592                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4593                 enddo
4594                 do k=1,3
4595                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4596                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4597                 enddo
4598                 gggp(1)=gggp(1)+ees0pijp*xj &
4599                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4600                 gggp(2)=gggp(2)+ees0pijp*yj &
4601                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4602                 gggp(3)=gggp(3)+ees0pijp*zj &
4603                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4604
4605                 gggm(1)=gggm(1)+ees0mijp*xj &
4606                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4607
4608                 gggm(2)=gggm(2)+ees0mijp*yj &
4609                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4610
4611                 gggm(3)=gggm(3)+ees0mijp*zj &
4612                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4613
4614 ! Derivatives due to the contact function
4615                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4616                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4617                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4618                 do k=1,3
4619 !
4620 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4621 !          following the change of gradient-summation algorithm.
4622 !
4623 !grad                  ghalfp=0.5D0*gggp(k)
4624 !grad                  ghalfm=0.5D0*gggm(k)
4625                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4626                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4627                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4628                      *sss_ele_cut*fac_shield(i)*fac_shield(j) ! &
4629 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4630
4631
4632                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4633                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4634                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4635                      *sss_ele_cut*fac_shield(i)*fac_shield(j)!   &
4636 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4637
4638
4639                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4640                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4641 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4642
4643                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4644                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4645                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4646                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4647 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4648
4649                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4650                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4651                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4652                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4653 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4654
4655                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4656                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4657 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4658
4659                 enddo
4660 ! Diagnostics. Comment out or remove after debugging!
4661 !diag           do k=1,3
4662 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4663 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4664 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4665 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4666 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4667 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4668 !diag           enddo
4669               ENDIF ! wcorr
4670               endif  ! num_conti.le.maxconts
4671             endif  ! fcont.gt.0
4672           endif    ! j.gt.i+1
4673           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4674             do k=1,4
4675               do l=1,3
4676                 ghalf=0.5d0*agg(l,k)
4677                 aggi(l,k)=aggi(l,k)+ghalf
4678                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4679                 aggj(l,k)=aggj(l,k)+ghalf
4680               enddo
4681             enddo
4682             if (j.eq.nres-1 .and. i.lt.j-2) then
4683               do k=1,4
4684                 do l=1,3
4685                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4686                 enddo
4687               enddo
4688             endif
4689           endif
4690  128  continue
4691 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4692       return
4693       end subroutine eelecij
4694 !-----------------------------------------------------------------------------
4695       subroutine eturn3(i,eello_turn3)
4696 ! Third- and fourth-order contributions from turns
4697
4698       use comm_locel
4699 !      implicit real*8 (a-h,o-z)
4700 !      include 'DIMENSIONS'
4701 !      include 'COMMON.IOUNITS'
4702 !      include 'COMMON.GEO'
4703 !      include 'COMMON.VAR'
4704 !      include 'COMMON.LOCAL'
4705 !      include 'COMMON.CHAIN'
4706 !      include 'COMMON.DERIV'
4707 !      include 'COMMON.INTERACT'
4708 !      include 'COMMON.CONTACTS'
4709 !      include 'COMMON.TORSION'
4710 !      include 'COMMON.VECTORS'
4711 !      include 'COMMON.FFIELD'
4712 !      include 'COMMON.CONTROL'
4713       real(kind=8),dimension(3) :: ggg
4714       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4715         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,gpizda1,&
4716        gpizda2,auxgmat1,auxgmatt1,auxgmat2,auxgmatt2
4717
4718       real(kind=8),dimension(2) :: auxvec,auxvec1
4719 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4720       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4721 !el      integer :: num_conti,j1,j2
4722 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4723 !el        dz_normi,xmedi,ymedi,zmedi
4724
4725 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4726 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4727 !el         num_conti,j1,j2
4728 !el local variables
4729       integer :: i,j,l,k,ilist,iresshield
4730       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield,xj,yj
4731       xj=0.0d0
4732       yj=0.0d0
4733       j=i+2
4734 !      write (iout,*) "eturn3",i,j,j1,j2
4735           zj=(c(3,j)+c(3,j+1))/2.0d0
4736             call to_box(xj,yj,zj)
4737             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
4738
4739       a_temp(1,1)=a22
4740       a_temp(1,2)=a23
4741       a_temp(2,1)=a32
4742       a_temp(2,2)=a33
4743 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4744 !
4745 !               Third-order contributions
4746 !
4747 !                 (i+2)o----(i+3)
4748 !                      | |
4749 !                      | |
4750 !                 (i+1)o----i
4751 !
4752 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4753 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4754         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4755         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4756         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4757         call transpose2(auxmat(1,1),auxmat1(1,1))
4758         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4759         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4760         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4761         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4762         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4763
4764         if (shield_mode.eq.0) then
4765         fac_shield(i)=1.0d0
4766         fac_shield(j)=1.0d0
4767         endif
4768
4769         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4770          *fac_shield(i)*fac_shield(j)  &
4771          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4772         eello_t3= &
4773         0.5d0*(pizda(1,1)+pizda(2,2)) &
4774         *fac_shield(i)*fac_shield(j)
4775
4776         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4777                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4778 !C#ifdef NEWCORR
4779 !C Derivatives in theta
4780         gloc(nphi+i,icg)=gloc(nphi+i,icg) &
4781        +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3&
4782         *fac_shield(i)*fac_shield(j) &
4783         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4784
4785         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)&
4786        +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3&
4787         *fac_shield(i)*fac_shield(j) &
4788         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4789
4790
4791 !C#endif
4792
4793
4794
4795           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4796        (shield_mode.gt.0)) then
4797 !C          print *,i,j
4798
4799           do ilist=1,ishield_list(i)
4800            iresshield=shield_list(ilist,i)
4801            do k=1,3
4802            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4803            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4804                    rlocshield &
4805            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4806             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4807              +rlocshield
4808            enddo
4809           enddo
4810           do ilist=1,ishield_list(j)
4811            iresshield=shield_list(ilist,j)
4812            do k=1,3
4813            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4814            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4815                    rlocshield &
4816            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4817            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4818                   +rlocshield
4819
4820            enddo
4821           enddo
4822
4823           do k=1,3
4824             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4825                    grad_shield(k,i)*eello_t3/fac_shield(i)
4826             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4827                    grad_shield(k,j)*eello_t3/fac_shield(j)
4828             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4829                    grad_shield(k,i)*eello_t3/fac_shield(i)
4830             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4831                    grad_shield(k,j)*eello_t3/fac_shield(j)
4832            enddo
4833            endif
4834
4835 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4836 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4837 !d     &    ' eello_turn3_num',4*eello_turn3_num
4838 ! Derivatives in gamma(i)
4839         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4840         call transpose2(auxmat2(1,1),auxmat3(1,1))
4841         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4842         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4843           *fac_shield(i)*fac_shield(j)        &
4844           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4845 ! Derivatives in gamma(i+1)
4846         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4847         call transpose2(auxmat2(1,1),auxmat3(1,1))
4848         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4849         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4850           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4851           *fac_shield(i)*fac_shield(j)        &
4852           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4853
4854 ! Cartesian derivatives
4855         do l=1,3
4856 !            ghalf1=0.5d0*agg(l,1)
4857 !            ghalf2=0.5d0*agg(l,2)
4858 !            ghalf3=0.5d0*agg(l,3)
4859 !            ghalf4=0.5d0*agg(l,4)
4860           a_temp(1,1)=aggi(l,1)!+ghalf1
4861           a_temp(1,2)=aggi(l,2)!+ghalf2
4862           a_temp(2,1)=aggi(l,3)!+ghalf3
4863           a_temp(2,2)=aggi(l,4)!+ghalf4
4864           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4865           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4866             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4867           *fac_shield(i)*fac_shield(j)      &
4868           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4869
4870           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4871           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4872           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4873           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4874           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4875           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4876             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4877           *fac_shield(i)*fac_shield(j)        &
4878           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4879
4880           a_temp(1,1)=aggj(l,1)!+ghalf1
4881           a_temp(1,2)=aggj(l,2)!+ghalf2
4882           a_temp(2,1)=aggj(l,3)!+ghalf3
4883           a_temp(2,2)=aggj(l,4)!+ghalf4
4884           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4885           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4886             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4887           *fac_shield(i)*fac_shield(j)      &
4888           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4889
4890           a_temp(1,1)=aggj1(l,1)
4891           a_temp(1,2)=aggj1(l,2)
4892           a_temp(2,1)=aggj1(l,3)
4893           a_temp(2,2)=aggj1(l,4)
4894           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4895           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4896             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4897           *fac_shield(i)*fac_shield(j)        &
4898           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4899         enddo
4900          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4901           ssgradlipi*eello_t3/4.0d0*lipscale
4902          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4903           ssgradlipj*eello_t3/4.0d0*lipscale
4904          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4905           ssgradlipi*eello_t3/4.0d0*lipscale
4906          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4907           ssgradlipj*eello_t3/4.0d0*lipscale
4908
4909       return
4910       end subroutine eturn3
4911 !-----------------------------------------------------------------------------
4912       subroutine eturn4(i,eello_turn4)
4913 ! Third- and fourth-order contributions from turns
4914
4915       use comm_locel
4916 !      implicit real*8 (a-h,o-z)
4917 !      include 'DIMENSIONS'
4918 !      include 'COMMON.IOUNITS'
4919 !      include 'COMMON.GEO'
4920 !      include 'COMMON.VAR'
4921 !      include 'COMMON.LOCAL'
4922 !      include 'COMMON.CHAIN'
4923 !      include 'COMMON.DERIV'
4924 !      include 'COMMON.INTERACT'
4925 !      include 'COMMON.CONTACTS'
4926 !      include 'COMMON.TORSION'
4927 !      include 'COMMON.VECTORS'
4928 !      include 'COMMON.FFIELD'
4929 !      include 'COMMON.CONTROL'
4930       real(kind=8),dimension(3) :: ggg
4931       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4932         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,&
4933         gte1t,gte2t,gte3t,&
4934         gte1a,gtae3,gtae3e2, ae3gte2,&
4935         gtEpizda1,gtEpizda2,gtEpizda3
4936
4937       real(kind=8),dimension(2) :: auxvec,auxvec1,auxgEvec1,auxgEvec2,&
4938        auxgEvec3,auxgvec
4939
4940 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4941       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4942 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4943 !el        dz_normi,xmedi,ymedi,zmedi
4944 !el      integer :: num_conti,j1,j2
4945 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4946 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4947 !el          num_conti,j1,j2
4948 !el local variables
4949       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4950       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4951          rlocshield,gs23,gs32,gsE13,gs13,gs21,gsE31,gsEE1,gsEE2,gsEE3,xj,yj
4952       xj=0.0d0
4953       yj=0.0d0
4954       j=i+3
4955 !      if (j.ne.20) return
4956 !      print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1)
4957 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4958 !
4959 !               Fourth-order contributions
4960 !
4961 !                 (i+3)o----(i+4)
4962 !                     /  |
4963 !               (i+2)o   |
4964 !                     \  |
4965 !                 (i+1)o----i
4966 !
4967 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4968 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4969 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4970           zj=(c(3,j)+c(3,j+1))/2.0d0
4971             call to_box(xj,yj,zj)
4972             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
4973
4974
4975         a_temp(1,1)=a22
4976         a_temp(1,2)=a23
4977         a_temp(2,1)=a32
4978         a_temp(2,2)=a33
4979         iti1=i+1
4980         iti2=i+2
4981         iti3=i+3
4982 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4983         call transpose2(EUg(1,1,i+1),e1t(1,1))
4984         call transpose2(Eug(1,1,i+2),e2t(1,1))
4985         call transpose2(Eug(1,1,i+3),e3t(1,1))
4986 !C Ematrix derivative in theta
4987         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4988         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4989         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4990
4991         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4992         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4993         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4994         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4995 !c       auxalary matrix of E i+1
4996         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4997         s1=scalar2(b1(1,iti2),auxvec(1))
4998 !c derivative of theta i+2 with constant i+3
4999         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5000 !c derivative of theta i+2 with constant i+2
5001         gs32=scalar2(b1(1,i+2),auxgvec(1))
5002 !c derivative of E matix in theta of i+1
5003         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5004
5005         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5006         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5007         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5008 !c auxilary matrix auxgvec of Ub2 with constant E matirx
5009         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5010 !c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5011         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5012         s2=scalar2(b1(1,i+1),auxvec(1))
5013 !c derivative of theta i+1 with constant i+3
5014         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5015 !c derivative of theta i+2 with constant i+1
5016         gs21=scalar2(b1(1,i+1),auxgvec(1))
5017 !c derivative of theta i+3 with constant i+1
5018         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5019
5020         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5021         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5022 !c ae3gte2 is derivative over i+2
5023         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5024
5025         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5026         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5027 !c i+2
5028         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5029 !c i+3
5030         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5031
5032         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5033         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5034         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5035         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5036         if (shield_mode.eq.0) then
5037         fac_shield(i)=1.0
5038         fac_shield(j)=1.0
5039         endif
5040
5041         eello_turn4=eello_turn4-(s1+s2+s3) &
5042         *fac_shield(i)*fac_shield(j)       &
5043         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5044         eello_t4=-(s1+s2+s3)  &
5045           *fac_shield(i)*fac_shield(j)
5046 !C Now derivative over shield:
5047           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
5048          (shield_mode.gt.0)) then
5049 !C          print *,i,j
5050
5051           do ilist=1,ishield_list(i)
5052            iresshield=shield_list(ilist,i)
5053            do k=1,3
5054            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5055 !           print *,"rlocshield",rlocshield,grad_shield_side(k,ilist,i),iresshield
5056            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5057                    rlocshield &
5058             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5059             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5060            +rlocshield
5061            enddo
5062           enddo
5063           do ilist=1,ishield_list(j)
5064            iresshield=shield_list(ilist,j)
5065            do k=1,3
5066 !           print *,"rlocshieldj",j,rlocshield,grad_shield_side(k,ilist,j),iresshield
5067            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5068            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5069                    rlocshield  &
5070            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5071            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5072                   +rlocshield
5073 !            print *,"after", gshieldc_t4(k,iresshield-1),iresshield-1,gshieldc_t4(k,iresshield)
5074
5075            enddo
5076           enddo
5077           do k=1,3
5078             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
5079                    grad_shield(k,i)*eello_t4/fac_shield(i)
5080             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
5081                    grad_shield(k,j)*eello_t4/fac_shield(j)
5082             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
5083                    grad_shield(k,i)*eello_t4/fac_shield(i)
5084             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
5085                    grad_shield(k,j)*eello_t4/fac_shield(j)
5086 !           print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1)
5087            enddo
5088            endif
5089 #ifdef NEWCORR
5090         gloc(nphi+i,icg)=gloc(nphi+i,icg)&
5091                        -(gs13+gsE13+gsEE1)*wturn4&
5092        *fac_shield(i)*fac_shield(j) &
5093        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5094
5095         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)&
5096                          -(gs23+gs21+gsEE2)*wturn4&
5097        *fac_shield(i)*fac_shield(j)&
5098        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5099
5100         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)&
5101                          -(gs32+gsE31+gsEE3)*wturn4&
5102        *fac_shield(i)*fac_shield(j)&
5103        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5104
5105
5106 !c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5107 !c     &   gs2
5108 #endif
5109         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5110            'eturn4',i,j,-(s1+s2+s3)
5111 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5112 !d     &    ' eello_turn4_num',8*eello_turn4_num
5113 ! Derivatives in gamma(i)
5114         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5115         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5116         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5117         s1=scalar2(b1(1,i+1),auxvec(1))
5118         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5119         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5120         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
5121        *fac_shield(i)*fac_shield(j)  &
5122        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5123
5124 ! Derivatives in gamma(i+1)
5125         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5126         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5127         s2=scalar2(b1(1,iti1),auxvec(1))
5128         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5129         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5130         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5131         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
5132        *fac_shield(i)*fac_shield(j)  &
5133        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5134
5135 ! Derivatives in gamma(i+2)
5136         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5137         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5138         s1=scalar2(b1(1,iti2),auxvec(1))
5139         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5140         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5141         s2=scalar2(b1(1,iti1),auxvec(1))
5142         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5143         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5144         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5145         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
5146        *fac_shield(i)*fac_shield(j)  &
5147        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5148
5149 ! Cartesian derivatives
5150 ! Derivatives of this turn contributions in DC(i+2)
5151         if (j.lt.nres-1) then
5152           do l=1,3
5153             a_temp(1,1)=agg(l,1)
5154             a_temp(1,2)=agg(l,2)
5155             a_temp(2,1)=agg(l,3)
5156             a_temp(2,2)=agg(l,4)
5157             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5158             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5159             s1=scalar2(b1(1,iti2),auxvec(1))
5160             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5161             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5162             s2=scalar2(b1(1,iti1),auxvec(1))
5163             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5164             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5165             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5166             ggg(l)=-(s1+s2+s3)
5167             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
5168        *fac_shield(i)*fac_shield(j)  &
5169        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5170
5171           enddo
5172         endif
5173 ! Remaining derivatives of this turn contribution
5174         do l=1,3
5175           a_temp(1,1)=aggi(l,1)
5176           a_temp(1,2)=aggi(l,2)
5177           a_temp(2,1)=aggi(l,3)
5178           a_temp(2,2)=aggi(l,4)
5179           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5180           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5181           s1=scalar2(b1(1,iti2),auxvec(1))
5182           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5183           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5184           s2=scalar2(b1(1,iti1),auxvec(1))
5185           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5186           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5187           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5188           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
5189          *fac_shield(i)*fac_shield(j)  &
5190          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5191
5192
5193           a_temp(1,1)=aggi1(l,1)
5194           a_temp(1,2)=aggi1(l,2)
5195           a_temp(2,1)=aggi1(l,3)
5196           a_temp(2,2)=aggi1(l,4)
5197           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5198           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5199           s1=scalar2(b1(1,iti2),auxvec(1))
5200           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5201           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5202           s2=scalar2(b1(1,iti1),auxvec(1))
5203           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5204           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5205           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5206           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
5207          *fac_shield(i)*fac_shield(j)  &
5208          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5209
5210
5211           a_temp(1,1)=aggj(l,1)
5212           a_temp(1,2)=aggj(l,2)
5213           a_temp(2,1)=aggj(l,3)
5214           a_temp(2,2)=aggj(l,4)
5215           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5216           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5217           s1=scalar2(b1(1,iti2),auxvec(1))
5218           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5219           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5220           s2=scalar2(b1(1,iti1),auxvec(1))
5221           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5222           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5223           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5224 !        if (j.lt.nres-1) then
5225           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
5226          *fac_shield(i)*fac_shield(j)  &
5227          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5228 !        endif
5229
5230           a_temp(1,1)=aggj1(l,1)
5231           a_temp(1,2)=aggj1(l,2)
5232           a_temp(2,1)=aggj1(l,3)
5233           a_temp(2,2)=aggj1(l,4)
5234           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5235           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5236           s1=scalar2(b1(1,iti2),auxvec(1))
5237           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5238           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5239           s2=scalar2(b1(1,iti1),auxvec(1))
5240           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5241           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5242           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5243 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5244 !        if (j.lt.nres-1) then
5245 !          print *,"juest before",j1, gcorr4_turn(l,j1)
5246           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
5247          *fac_shield(i)*fac_shield(j)  &
5248          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5249 !            if (shield_mode.gt.0) then
5250 !             print *,"juest after",j1, gcorr4_turn(l,j1),gshieldc_t4(k,j1),gshieldc_loc_t4(k,j1),gel_loc_turn4(i+2)
5251 !            else
5252 !             print *,"juest after",j1, gcorr4_turn(l,j1),gel_loc_turn4(i+2)
5253 !            endif
5254 !         endif
5255         enddo
5256          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
5257           ssgradlipi*eello_t4/4.0d0*lipscale
5258          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
5259           ssgradlipj*eello_t4/4.0d0*lipscale
5260          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
5261           ssgradlipi*eello_t4/4.0d0*lipscale
5262          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
5263           ssgradlipj*eello_t4/4.0d0*lipscale
5264
5265       return
5266       end subroutine eturn4
5267 !-----------------------------------------------------------------------------
5268       subroutine unormderiv(u,ugrad,unorm,ungrad)
5269 ! This subroutine computes the derivatives of a normalized vector u, given
5270 ! the derivatives computed without normalization conditions, ugrad. Returns
5271 ! ungrad.
5272 !      implicit none
5273       real(kind=8),dimension(3) :: u,vec
5274       real(kind=8),dimension(3,3) ::ugrad,ungrad
5275       real(kind=8) :: unorm      !,scalar
5276       integer :: i,j
5277 !      write (2,*) 'ugrad',ugrad
5278 !      write (2,*) 'u',u
5279       do i=1,3
5280         vec(i)=scalar(ugrad(1,i),u(1))
5281       enddo
5282 !      write (2,*) 'vec',vec
5283       do i=1,3
5284         do j=1,3
5285           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5286         enddo
5287       enddo
5288 !      write (2,*) 'ungrad',ungrad
5289       return
5290       end subroutine unormderiv
5291 !-----------------------------------------------------------------------------
5292       subroutine escp_soft_sphere(evdw2,evdw2_14)
5293 !
5294 ! This subroutine calculates the excluded-volume interaction energy between
5295 ! peptide-group centers and side chains and its gradient in virtual-bond and
5296 ! side-chain vectors.
5297 !
5298 !      implicit real*8 (a-h,o-z)
5299 !      include 'DIMENSIONS'
5300 !      include 'COMMON.GEO'
5301 !      include 'COMMON.VAR'
5302 !      include 'COMMON.LOCAL'
5303 !      include 'COMMON.CHAIN'
5304 !      include 'COMMON.DERIV'
5305 !      include 'COMMON.INTERACT'
5306 !      include 'COMMON.FFIELD'
5307 !      include 'COMMON.IOUNITS'
5308 !      include 'COMMON.CONTROL'
5309       real(kind=8),dimension(3) :: ggg
5310 !el local variables
5311       integer :: i,iint,j,k,iteli,itypj
5312       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
5313                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
5314
5315       evdw2=0.0D0
5316       evdw2_14=0.0d0
5317       r0_scp=4.5d0
5318 !d    print '(a)','Enter ESCP'
5319 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5320       do i=iatscp_s,iatscp_e
5321         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5322         iteli=itel(i)
5323         xi=0.5D0*(c(1,i)+c(1,i+1))
5324         yi=0.5D0*(c(2,i)+c(2,i+1))
5325         zi=0.5D0*(c(3,i)+c(3,i+1))
5326           call to_box(xi,yi,zi)
5327
5328         do iint=1,nscp_gr(i)
5329
5330         do j=iscpstart(i,iint),iscpend(i,iint)
5331           if (itype(j,1).eq.ntyp1) cycle
5332           itypj=iabs(itype(j,1))
5333 ! Uncomment following three lines for SC-p interactions
5334 !         xj=c(1,nres+j)-xi
5335 !         yj=c(2,nres+j)-yi
5336 !         zj=c(3,nres+j)-zi
5337 ! Uncomment following three lines for Ca-p interactions
5338           xj=c(1,j)-xi
5339           yj=c(2,j)-yi
5340           zj=c(3,j)-zi
5341           call to_box(xj,yj,zj)
5342           xj=boxshift(xj-xi,boxxsize)
5343           yj=boxshift(yj-yi,boxysize)
5344           zj=boxshift(zj-zi,boxzsize)
5345           rij=xj*xj+yj*yj+zj*zj
5346           r0ij=r0_scp
5347           r0ijsq=r0ij*r0ij
5348           if (rij.lt.r0ijsq) then
5349             evdwij=0.25d0*(rij-r0ijsq)**2
5350             fac=rij-r0ijsq
5351           else
5352             evdwij=0.0d0
5353             fac=0.0d0
5354           endif
5355           evdw2=evdw2+evdwij
5356 !
5357 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5358 !
5359           ggg(1)=xj*fac
5360           ggg(2)=yj*fac
5361           ggg(3)=zj*fac
5362 !grad          if (j.lt.i) then
5363 !d          write (iout,*) 'j<i'
5364 ! Uncomment following three lines for SC-p interactions
5365 !           do k=1,3
5366 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5367 !           enddo
5368 !grad          else
5369 !d          write (iout,*) 'j>i'
5370 !grad            do k=1,3
5371 !grad              ggg(k)=-ggg(k)
5372 ! Uncomment following line for SC-p interactions
5373 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5374 !grad            enddo
5375 !grad          endif
5376 !grad          do k=1,3
5377 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5378 !grad          enddo
5379 !grad          kstart=min0(i+1,j)
5380 !grad          kend=max0(i-1,j-1)
5381 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5382 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5383 !grad          do k=kstart,kend
5384 !grad            do l=1,3
5385 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5386 !grad            enddo
5387 !grad          enddo
5388           do k=1,3
5389             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5390             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5391           enddo
5392         enddo
5393
5394         enddo ! iint
5395       enddo ! i
5396       return
5397       end subroutine escp_soft_sphere
5398 !-----------------------------------------------------------------------------
5399       subroutine escp(evdw2,evdw2_14)
5400 !
5401 ! This subroutine calculates the excluded-volume interaction energy between
5402 ! peptide-group centers and side chains and its gradient in virtual-bond and
5403 ! side-chain vectors.
5404 !
5405 !      implicit real*8 (a-h,o-z)
5406 !      include 'DIMENSIONS'
5407 !      include 'COMMON.GEO'
5408 !      include 'COMMON.VAR'
5409 !      include 'COMMON.LOCAL'
5410 !      include 'COMMON.CHAIN'
5411 !      include 'COMMON.DERIV'
5412 !      include 'COMMON.INTERACT'
5413 !      include 'COMMON.FFIELD'
5414 !      include 'COMMON.IOUNITS'
5415 !      include 'COMMON.CONTROL'
5416       real(kind=8),dimension(3) :: ggg
5417 !el local variables
5418       integer :: i,iint,j,k,iteli,itypj,subchap,icont
5419       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
5420                    e1,e2,evdwij,rij
5421       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
5422                     dist_temp, dist_init
5423       integer xshift,yshift,zshift
5424
5425       evdw2=0.0D0
5426       evdw2_14=0.0d0
5427 !d    print '(a)','Enter ESCP'
5428 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5429 !      do i=iatscp_s,iatscp_e
5430       if (nres_molec(1).eq.0) return
5431        do icont=g_listscp_start,g_listscp_end
5432         i=newcontlistscpi(icont)
5433         j=newcontlistscpj(icont)
5434         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5435         iteli=itel(i)
5436         xi=0.5D0*(c(1,i)+c(1,i+1))
5437         yi=0.5D0*(c(2,i)+c(2,i+1))
5438         zi=0.5D0*(c(3,i)+c(3,i+1))
5439         call to_box(xi,yi,zi)
5440
5441 !        do iint=1,nscp_gr(i)
5442
5443 !        do j=iscpstart(i,iint),iscpend(i,iint)
5444           itypj=iabs(itype(j,1))
5445           if (itypj.eq.ntyp1) cycle
5446 ! Uncomment following three lines for SC-p interactions
5447 !         xj=c(1,nres+j)-xi
5448 !         yj=c(2,nres+j)-yi
5449 !         zj=c(3,nres+j)-zi
5450 ! Uncomment following three lines for Ca-p interactions
5451 !          xj=c(1,j)-xi
5452 !          yj=c(2,j)-yi
5453 !          zj=c(3,j)-zi
5454           xj=c(1,j)
5455           yj=c(2,j)
5456           zj=c(3,j)
5457
5458           call to_box(xj,yj,zj)
5459           xj=boxshift(xj-xi,boxxsize)
5460           yj=boxshift(yj-yi,boxysize)
5461           zj=boxshift(zj-zi,boxzsize)
5462
5463           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5464           rij=dsqrt(1.0d0/rrij)
5465             sss_ele_cut=sscale_ele(rij)
5466             sss_ele_grad=sscagrad_ele(rij)
5467 !            print *,sss_ele_cut,sss_ele_grad,&
5468 !            (rij),r_cut_ele,rlamb_ele
5469             if (sss_ele_cut.le.0.0) cycle
5470           fac=rrij**expon2
5471           e1=fac*fac*aad(itypj,iteli)
5472           e2=fac*bad(itypj,iteli)
5473           if (iabs(j-i) .le. 2) then
5474             e1=scal14*e1
5475             e2=scal14*e2
5476             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5477           endif
5478           evdwij=e1+e2
5479           evdw2=evdw2+evdwij*sss_ele_cut
5480 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5481 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5482           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5483              'evdw2',i,j,evdwij
5484 !
5485 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5486 !
5487           fac=-(evdwij+e1)*rrij*sss_ele_cut
5488           fac=fac+evdwij*sss_ele_grad/rij/expon
5489           ggg(1)=xj*fac
5490           ggg(2)=yj*fac
5491           ggg(3)=zj*fac
5492 !grad          if (j.lt.i) then
5493 !d          write (iout,*) 'j<i'
5494 ! Uncomment following three lines for SC-p interactions
5495 !           do k=1,3
5496 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5497 !           enddo
5498 !grad          else
5499 !d          write (iout,*) 'j>i'
5500 !grad            do k=1,3
5501 !grad              ggg(k)=-ggg(k)
5502 ! Uncomment following line for SC-p interactions
5503 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5504 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5505 !grad            enddo
5506 !grad          endif
5507 !grad          do k=1,3
5508 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5509 !grad          enddo
5510 !grad          kstart=min0(i+1,j)
5511 !grad          kend=max0(i-1,j-1)
5512 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5513 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5514 !grad          do k=kstart,kend
5515 !grad            do l=1,3
5516 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5517 !grad            enddo
5518 !grad          enddo
5519           do k=1,3
5520             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5521             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5522           enddo
5523 !        enddo
5524
5525 !        enddo ! iint
5526       enddo ! i
5527       do i=1,nct
5528         do j=1,3
5529           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5530           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5531           gradx_scp(j,i)=expon*gradx_scp(j,i)
5532         enddo
5533       enddo
5534 !******************************************************************************
5535 !
5536 !                              N O T E !!!
5537 !
5538 ! To save time the factor EXPON has been extracted from ALL components
5539 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5540 ! use!
5541 !
5542 !******************************************************************************
5543       return
5544       end subroutine escp
5545 !-----------------------------------------------------------------------------
5546       subroutine edis(ehpb)
5547 !
5548 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5549 !
5550 !      implicit real*8 (a-h,o-z)
5551 !      include 'DIMENSIONS'
5552 !      include 'COMMON.SBRIDGE'
5553 !      include 'COMMON.CHAIN'
5554 !      include 'COMMON.DERIV'
5555 !      include 'COMMON.VAR'
5556 !      include 'COMMON.INTERACT'
5557 !      include 'COMMON.IOUNITS'
5558       real(kind=8),dimension(3) :: ggg
5559 !el local variables
5560       integer :: i,j,ii,jj,iii,jjj,k
5561       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5562
5563       ehpb=0.0D0
5564 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5565 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5566       if (link_end.eq.0) return
5567       do i=link_start,link_end
5568 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5569 ! CA-CA distance used in regularization of structure.
5570         ii=ihpb(i)
5571         jj=jhpb(i)
5572 ! iii and jjj point to the residues for which the distance is assigned.
5573         if (ii.gt.nres) then
5574           iii=ii-nres
5575           jjj=jj-nres
5576         else
5577           iii=ii
5578           jjj=jj
5579         endif
5580 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5581 !     &    dhpb(i),dhpb1(i),forcon(i)
5582 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5583 !    distance and angle dependent SS bond potential.
5584 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5585 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5586         if (.not.dyn_ss .and. i.le.nss) then
5587 ! 15/02/13 CC dynamic SSbond - additional check
5588          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5589         iabs(itype(jjj,1)).eq.1) then
5590           call ssbond_ene(iii,jjj,eij)
5591           ehpb=ehpb+2*eij
5592 !          write (iout,*) "eij",eij,iii,jjj
5593          endif
5594         else if (ii.gt.nres .and. jj.gt.nres) then
5595 !c Restraints from contact prediction
5596           dd=dist(ii,jj)
5597           if (constr_dist.eq.11) then
5598             ehpb=ehpb+fordepth(i)**4.0d0 &
5599                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5600             fac=fordepth(i)**4.0d0 &
5601                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5602           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5603             ehpb,fordepth(i),dd
5604            else
5605           if (dhpb1(i).gt.0.0d0) then
5606             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5607             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5608 !c            write (iout,*) "beta nmr",
5609 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5610           else
5611             dd=dist(ii,jj)
5612             rdis=dd-dhpb(i)
5613 !C Get the force constant corresponding to this distance.
5614             waga=forcon(i)
5615 !C Calculate the contribution to energy.
5616             ehpb=ehpb+waga*rdis*rdis
5617 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5618 !C
5619 !C Evaluate gradient.
5620 !C
5621             fac=waga*rdis/dd
5622           endif
5623           endif
5624           do j=1,3
5625             ggg(j)=fac*(c(j,jj)-c(j,ii))
5626           enddo
5627           do j=1,3
5628             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5629             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5630           enddo
5631           do k=1,3
5632             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5633             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5634           enddo
5635         else
5636           dd=dist(ii,jj)
5637           if (constr_dist.eq.11) then
5638             ehpb=ehpb+fordepth(i)**4.0d0 &
5639                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5640             fac=fordepth(i)**4.0d0 &
5641                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5642           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5643          ehpb,fordepth(i),dd
5644            else
5645           if (dhpb1(i).gt.0.0d0) then
5646             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5647             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5648 !c            write (iout,*) "alph nmr",
5649 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5650           else
5651             rdis=dd-dhpb(i)
5652 !C Get the force constant corresponding to this distance.
5653             waga=forcon(i)
5654 !C Calculate the contribution to energy.
5655             ehpb=ehpb+waga*rdis*rdis
5656 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5657 !C
5658 !C Evaluate gradient.
5659 !C
5660             fac=waga*rdis/dd
5661           endif
5662           endif
5663
5664             do j=1,3
5665               ggg(j)=fac*(c(j,jj)-c(j,ii))
5666             enddo
5667 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5668 !C If this is a SC-SC distance, we need to calculate the contributions to the
5669 !C Cartesian gradient in the SC vectors (ghpbx).
5670           if (iii.lt.ii) then
5671           do j=1,3
5672             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5673             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5674           enddo
5675           endif
5676 !cgrad        do j=iii,jjj-1
5677 !cgrad          do k=1,3
5678 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5679 !cgrad          enddo
5680 !cgrad        enddo
5681           do k=1,3
5682             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5683             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5684           enddo
5685         endif
5686       enddo
5687       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5688
5689       return
5690       end subroutine edis
5691 !-----------------------------------------------------------------------------
5692       subroutine ssbond_ene(i,j,eij)
5693 !
5694 ! Calculate the distance and angle dependent SS-bond potential energy
5695 ! using a free-energy function derived based on RHF/6-31G** ab initio
5696 ! calculations of diethyl disulfide.
5697 !
5698 ! A. Liwo and U. Kozlowska, 11/24/03
5699 !
5700 !      implicit real*8 (a-h,o-z)
5701 !      include 'DIMENSIONS'
5702 !      include 'COMMON.SBRIDGE'
5703 !      include 'COMMON.CHAIN'
5704 !      include 'COMMON.DERIV'
5705 !      include 'COMMON.LOCAL'
5706 !      include 'COMMON.INTERACT'
5707 !      include 'COMMON.VAR'
5708 !      include 'COMMON.IOUNITS'
5709       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5710 !el local variables
5711       integer :: i,j,itypi,itypj,k
5712       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5713                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5714                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5715                    cosphi,ggk
5716
5717       itypi=iabs(itype(i,1))
5718       xi=c(1,nres+i)
5719       yi=c(2,nres+i)
5720       zi=c(3,nres+i)
5721           call to_box(xi,yi,zi)
5722
5723       dxi=dc_norm(1,nres+i)
5724       dyi=dc_norm(2,nres+i)
5725       dzi=dc_norm(3,nres+i)
5726 !      dsci_inv=dsc_inv(itypi)
5727       dsci_inv=vbld_inv(nres+i)
5728       itypj=iabs(itype(j,1))
5729 !      dscj_inv=dsc_inv(itypj)
5730       dscj_inv=vbld_inv(nres+j)
5731       xj=c(1,nres+j)
5732       yj=c(2,nres+j)
5733       zj=c(3,nres+j)
5734           call to_box(xj,yj,zj)
5735       xj=boxshift(xj-xi,boxxsize)
5736       yj=boxshift(yj-yi,boxysize)
5737       zj=boxshift(zj-zi,boxzsize)
5738       dxj=dc_norm(1,nres+j)
5739       dyj=dc_norm(2,nres+j)
5740       dzj=dc_norm(3,nres+j)
5741       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5742       rij=dsqrt(rrij)
5743       erij(1)=xj*rij
5744       erij(2)=yj*rij
5745       erij(3)=zj*rij
5746       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5747       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5748       om12=dxi*dxj+dyi*dyj+dzi*dzj
5749       do k=1,3
5750         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5751         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5752       enddo
5753       rij=1.0d0/rij
5754       deltad=rij-d0cm
5755       deltat1=1.0d0-om1
5756       deltat2=1.0d0+om2
5757       deltat12=om2-om1+2.0d0
5758       cosphi=om12-om1*om2
5759       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5760         +akct*deltad*deltat12 &
5761         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5762 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, &
5763 !       " akct",akct," deltad",deltad," deltat",deltat1,deltat2, &
5764 !       " deltat12",deltat12," eij",eij
5765       ed=2*akcm*deltad+akct*deltat12
5766       pom1=akct*deltad
5767       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5768       eom1=-2*akth*deltat1-pom1-om2*pom2
5769       eom2= 2*akth*deltat2+pom1-om1*pom2
5770       eom12=pom2
5771       do k=1,3
5772         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5773         ghpbx(k,i)=ghpbx(k,i)-ggk &
5774                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5775                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5776         ghpbx(k,j)=ghpbx(k,j)+ggk &
5777                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5778                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5779         ghpbc(k,i)=ghpbc(k,i)-ggk
5780         ghpbc(k,j)=ghpbc(k,j)+ggk
5781       enddo
5782 !
5783 ! Calculate the components of the gradient in DC and X
5784 !
5785 !grad      do k=i,j-1
5786 !grad        do l=1,3
5787 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5788 !grad        enddo
5789 !grad      enddo
5790       return
5791       end subroutine ssbond_ene
5792 !-----------------------------------------------------------------------------
5793       subroutine ebond(estr)
5794 !
5795 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5796 !
5797 !      implicit real*8 (a-h,o-z)
5798 !      include 'DIMENSIONS'
5799 !      include 'COMMON.LOCAL'
5800 !      include 'COMMON.GEO'
5801 !      include 'COMMON.INTERACT'
5802 !      include 'COMMON.DERIV'
5803 !      include 'COMMON.VAR'
5804 !      include 'COMMON.CHAIN'
5805 !      include 'COMMON.IOUNITS'
5806 !      include 'COMMON.NAMES'
5807 !      include 'COMMON.FFIELD'
5808 !      include 'COMMON.CONTROL'
5809 !      include 'COMMON.SETUP'
5810       real(kind=8),dimension(3) :: u,ud
5811 !el local variables
5812       integer :: i,j,iti,nbi,k
5813       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5814                    uprod1,uprod2
5815
5816       estr=0.0d0
5817       estr1=0.0d0
5818 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5819 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5820
5821       do i=ibondp_start,ibondp_end
5822         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5823         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5824 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5825 !C          do j=1,3
5826 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5827 !C            *dc(j,i-1)/vbld(i)
5828 !C          enddo
5829 !C          if (energy_dec) write(iout,*) &
5830 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5831         diff = vbld(i)-vbldpDUM
5832         else
5833         diff = vbld(i)-vbldp0
5834         endif
5835         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5836            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5837         estr=estr+diff*diff
5838         do j=1,3
5839           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5840         enddo
5841 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5842 !        endif
5843       enddo
5844       estr=0.5d0*AKP*estr+estr1
5845 !      print *,"estr_bb",estr,AKP
5846 !
5847 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5848 !
5849       do i=ibond_start,ibond_end
5850         iti=iabs(itype(i,1))
5851         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5852         if (iti.ne.10 .and. iti.ne.ntyp1) then
5853           nbi=nbondterm(iti)
5854           if (nbi.eq.1) then
5855             diff=vbld(i+nres)-vbldsc0(1,iti)
5856             if (energy_dec) write (iout,*) &
5857             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5858             AKSC(1,iti),AKSC(1,iti)*diff*diff
5859             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5860 !            print *,"estr_sc",estr
5861             do j=1,3
5862               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5863             enddo
5864           else
5865             do j=1,nbi
5866               diff=vbld(i+nres)-vbldsc0(j,iti)
5867               ud(j)=aksc(j,iti)*diff
5868               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5869             enddo
5870             uprod=u(1)
5871             do j=2,nbi
5872               uprod=uprod*u(j)
5873             enddo
5874             usum=0.0d0
5875             usumsqder=0.0d0
5876             do j=1,nbi
5877               uprod1=1.0d0
5878               uprod2=1.0d0
5879               do k=1,nbi
5880                 if (k.ne.j) then
5881                   uprod1=uprod1*u(k)
5882                   uprod2=uprod2*u(k)*u(k)
5883                 endif
5884               enddo
5885               usum=usum+uprod1
5886               usumsqder=usumsqder+ud(j)*uprod2
5887             enddo
5888             estr=estr+uprod/usum
5889 !            print *,"estr_sc",estr,i
5890
5891              if (energy_dec) write (iout,*) &
5892             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5893             AKSC(1,iti),uprod/usum
5894             do j=1,3
5895              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5896             enddo
5897           endif
5898         endif
5899       enddo
5900       return
5901       end subroutine ebond
5902 #ifdef CRYST_THETA
5903 !-----------------------------------------------------------------------------
5904       subroutine ebend(etheta)
5905 !
5906 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5907 ! angles gamma and its derivatives in consecutive thetas and gammas.
5908 !
5909       use comm_calcthet
5910 !      implicit real*8 (a-h,o-z)
5911 !      include 'DIMENSIONS'
5912 !      include 'COMMON.LOCAL'
5913 !      include 'COMMON.GEO'
5914 !      include 'COMMON.INTERACT'
5915 !      include 'COMMON.DERIV'
5916 !      include 'COMMON.VAR'
5917 !      include 'COMMON.CHAIN'
5918 !      include 'COMMON.IOUNITS'
5919 !      include 'COMMON.NAMES'
5920 !      include 'COMMON.FFIELD'
5921 !      include 'COMMON.CONTROL'
5922 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5923 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5924 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5925 !el      integer :: it
5926 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5927 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5928 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5929 !el local variables
5930       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5931        ichir21,ichir22
5932       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5933        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5934        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5935       real(kind=8),dimension(2) :: y,z
5936
5937       delta=0.02d0*pi
5938 !      time11=dexp(-2*time)
5939 !      time12=1.0d0
5940       etheta=0.0D0
5941 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5942       do i=ithet_start,ithet_end
5943         if (itype(i-1,1).eq.ntyp1) cycle
5944 ! Zero the energy function and its derivative at 0 or pi.
5945         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5946         it=itype(i-1,1)
5947         ichir1=isign(1,itype(i-2,1))
5948         ichir2=isign(1,itype(i,1))
5949          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5950          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5951          if (itype(i-1,1).eq.10) then
5952           itype1=isign(10,itype(i-2,1))
5953           ichir11=isign(1,itype(i-2,1))
5954           ichir12=isign(1,itype(i-2,1))
5955           itype2=isign(10,itype(i,1))
5956           ichir21=isign(1,itype(i,1))
5957           ichir22=isign(1,itype(i,1))
5958          endif
5959
5960         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5961 #ifdef OSF
5962           phii=phi(i)
5963           if (phii.ne.phii) phii=150.0
5964 #else
5965           phii=phi(i)
5966 #endif
5967           y(1)=dcos(phii)
5968           y(2)=dsin(phii)
5969         else
5970           y(1)=0.0D0
5971           y(2)=0.0D0
5972         endif
5973         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5974 #ifdef OSF
5975           phii1=phi(i+1)
5976           if (phii1.ne.phii1) phii1=150.0
5977           phii1=pinorm(phii1)
5978           z(1)=cos(phii1)
5979 #else
5980           phii1=phi(i+1)
5981           z(1)=dcos(phii1)
5982 #endif
5983           z(2)=dsin(phii1)
5984         else
5985           z(1)=0.0D0
5986           z(2)=0.0D0
5987         endif
5988 ! Calculate the "mean" value of theta from the part of the distribution
5989 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5990 ! In following comments this theta will be referred to as t_c.
5991         thet_pred_mean=0.0d0
5992         do k=1,2
5993             athetk=athet(k,it,ichir1,ichir2)
5994             bthetk=bthet(k,it,ichir1,ichir2)
5995           if (it.eq.10) then
5996              athetk=athet(k,itype1,ichir11,ichir12)
5997              bthetk=bthet(k,itype2,ichir21,ichir22)
5998           endif
5999          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6000         enddo
6001         dthett=thet_pred_mean*ssd
6002         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6003 ! Derivatives of the "mean" values in gamma1 and gamma2.
6004         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
6005                +athet(2,it,ichir1,ichir2)*y(1))*ss
6006         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
6007                +bthet(2,it,ichir1,ichir2)*z(1))*ss
6008          if (it.eq.10) then
6009         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
6010              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
6011         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
6012                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6013          endif
6014         if (theta(i).gt.pi-delta) then
6015           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
6016                E_tc0)
6017           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6018           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6019           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
6020               E_theta)
6021           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
6022               E_tc)
6023         else if (theta(i).lt.delta) then
6024           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6025           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6026           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
6027               E_theta)
6028           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6029           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
6030               E_tc)
6031         else
6032           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
6033               E_theta,E_tc)
6034         endif
6035         etheta=etheta+ethetai
6036         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6037             'ebend',i,ethetai
6038         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6039         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6040         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6041       enddo
6042 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6043
6044 ! Ufff.... We've done all this!!!
6045       return
6046       end subroutine ebend
6047 !-----------------------------------------------------------------------------
6048       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
6049
6050       use comm_calcthet
6051 !      implicit real*8 (a-h,o-z)
6052 !      include 'DIMENSIONS'
6053 !      include 'COMMON.LOCAL'
6054 !      include 'COMMON.IOUNITS'
6055 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6056 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6057 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6058       integer :: i,j,k
6059       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
6060 !el      integer :: it
6061 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6062 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6063 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6064 !el local variables
6065       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
6066        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6067
6068 ! Calculate the contributions to both Gaussian lobes.
6069 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6070 ! The "polynomial part" of the "standard deviation" of this part of
6071 ! the distribution.
6072         sig=polthet(3,it)
6073         do j=2,0,-1
6074           sig=sig*thet_pred_mean+polthet(j,it)
6075         enddo
6076 ! Derivative of the "interior part" of the "standard deviation of the"
6077 ! gamma-dependent Gaussian lobe in t_c.
6078         sigtc=3*polthet(3,it)
6079         do j=2,1,-1
6080           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6081         enddo
6082         sigtc=sig*sigtc
6083 ! Set the parameters of both Gaussian lobes of the distribution.
6084 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6085         fac=sig*sig+sigc0(it)
6086         sigcsq=fac+fac
6087         sigc=1.0D0/sigcsq
6088 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6089         sigsqtc=-4.0D0*sigcsq*sigtc
6090 !       print *,i,sig,sigtc,sigsqtc
6091 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
6092         sigtc=-sigtc/(fac*fac)
6093 ! Following variable is sigma(t_c)**(-2)
6094         sigcsq=sigcsq*sigcsq
6095         sig0i=sig0(it)
6096         sig0inv=1.0D0/sig0i**2
6097         delthec=thetai-thet_pred_mean
6098         delthe0=thetai-theta0i
6099         term1=-0.5D0*sigcsq*delthec*delthec
6100         term2=-0.5D0*sig0inv*delthe0*delthe0
6101 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6102 ! NaNs in taking the logarithm. We extract the largest exponent which is added
6103 ! to the energy (this being the log of the distribution) at the end of energy
6104 ! term evaluation for this virtual-bond angle.
6105         if (term1.gt.term2) then
6106           termm=term1
6107           term2=dexp(term2-termm)
6108           term1=1.0d0
6109         else
6110           termm=term2
6111           term1=dexp(term1-termm)
6112           term2=1.0d0
6113         endif
6114 ! The ratio between the gamma-independent and gamma-dependent lobes of
6115 ! the distribution is a Gaussian function of thet_pred_mean too.
6116         diffak=gthet(2,it)-thet_pred_mean
6117         ratak=diffak/gthet(3,it)**2
6118         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6119 ! Let's differentiate it in thet_pred_mean NOW.
6120         aktc=ak*ratak
6121 ! Now put together the distribution terms to make complete distribution.
6122         termexp=term1+ak*term2
6123         termpre=sigc+ak*sig0i
6124 ! Contribution of the bending energy from this theta is just the -log of
6125 ! the sum of the contributions from the two lobes and the pre-exponential
6126 ! factor. Simple enough, isn't it?
6127         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6128 ! NOW the derivatives!!!
6129 ! 6/6/97 Take into account the deformation.
6130         E_theta=(delthec*sigcsq*term1 &
6131              +ak*delthe0*sig0inv*term2)/termexp
6132         E_tc=((sigtc+aktc*sig0i)/termpre &
6133             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
6134              aktc*term2)/termexp)
6135       return
6136       end subroutine theteng
6137 #else
6138 !-----------------------------------------------------------------------------
6139       subroutine ebend(etheta)
6140 !
6141 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6142 ! angles gamma and its derivatives in consecutive thetas and gammas.
6143 ! ab initio-derived potentials from
6144 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6145 !
6146 !      implicit real*8 (a-h,o-z)
6147 !      include 'DIMENSIONS'
6148 !      include 'COMMON.LOCAL'
6149 !      include 'COMMON.GEO'
6150 !      include 'COMMON.INTERACT'
6151 !      include 'COMMON.DERIV'
6152 !      include 'COMMON.VAR'
6153 !      include 'COMMON.CHAIN'
6154 !      include 'COMMON.IOUNITS'
6155 !      include 'COMMON.NAMES'
6156 !      include 'COMMON.FFIELD'
6157 !      include 'COMMON.CONTROL'
6158       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
6159       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
6160       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
6161       logical :: lprn=.false., lprn1=.false.
6162 !el local variables
6163       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
6164       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
6165       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
6166 ! local variables for constrains
6167       real(kind=8) :: difi,thetiii
6168        integer itheta
6169 !      write(iout,*) "in ebend",ithet_start,ithet_end
6170       call flush(iout)
6171       etheta=0.0D0
6172       do i=ithet_start,ithet_end
6173         if (itype(i-1,1).eq.ntyp1) cycle
6174         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
6175         if (iabs(itype(i+1,1)).eq.20) iblock=2
6176         if (iabs(itype(i+1,1)).ne.20) iblock=1
6177         dethetai=0.0d0
6178         dephii=0.0d0
6179         dephii1=0.0d0
6180         theti2=0.5d0*theta(i)
6181         ityp2=ithetyp((itype(i-1,1)))
6182         do k=1,nntheterm
6183           coskt(k)=dcos(k*theti2)
6184           sinkt(k)=dsin(k*theti2)
6185         enddo
6186         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
6187 #ifdef OSF
6188           phii=phi(i)
6189           if (phii.ne.phii) phii=150.0
6190 #else
6191           phii=phi(i)
6192 #endif
6193           ityp1=ithetyp((itype(i-2,1)))
6194 ! propagation of chirality for glycine type
6195           do k=1,nsingle
6196             cosph1(k)=dcos(k*phii)
6197             sinph1(k)=dsin(k*phii)
6198           enddo
6199         else
6200           phii=0.0d0
6201           ityp1=ithetyp(itype(i-2,1))
6202           do k=1,nsingle
6203             cosph1(k)=0.0d0
6204             sinph1(k)=0.0d0
6205           enddo
6206         endif
6207         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
6208 #ifdef OSF
6209           phii1=phi(i+1)
6210           if (phii1.ne.phii1) phii1=150.0
6211           phii1=pinorm(phii1)
6212 #else
6213           phii1=phi(i+1)
6214 #endif
6215           ityp3=ithetyp((itype(i,1)))
6216           do k=1,nsingle
6217             cosph2(k)=dcos(k*phii1)
6218             sinph2(k)=dsin(k*phii1)
6219           enddo
6220         else
6221           phii1=0.0d0
6222           ityp3=ithetyp(itype(i,1))
6223           do k=1,nsingle
6224             cosph2(k)=0.0d0
6225             sinph2(k)=0.0d0
6226           enddo
6227         endif
6228         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6229         do k=1,ndouble
6230           do l=1,k-1
6231             ccl=cosph1(l)*cosph2(k-l)
6232             ssl=sinph1(l)*sinph2(k-l)
6233             scl=sinph1(l)*cosph2(k-l)
6234             csl=cosph1(l)*sinph2(k-l)
6235             cosph1ph2(l,k)=ccl-ssl
6236             cosph1ph2(k,l)=ccl+ssl
6237             sinph1ph2(l,k)=scl+csl
6238             sinph1ph2(k,l)=scl-csl
6239           enddo
6240         enddo
6241         if (lprn) then
6242         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
6243           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6244         write (iout,*) "coskt and sinkt"
6245         do k=1,nntheterm
6246           write (iout,*) k,coskt(k),sinkt(k)
6247         enddo
6248         endif
6249         do k=1,ntheterm
6250           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6251           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
6252             *coskt(k)
6253           if (lprn) &
6254           write (iout,*) "k",k,&
6255            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
6256            " ethetai",ethetai
6257         enddo
6258         if (lprn) then
6259         write (iout,*) "cosph and sinph"
6260         do k=1,nsingle
6261           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6262         enddo
6263         write (iout,*) "cosph1ph2 and sinph2ph2"
6264         do k=2,ndouble
6265           do l=1,k-1
6266             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
6267                sinph1ph2(l,k),sinph1ph2(k,l)
6268           enddo
6269         enddo
6270         write(iout,*) "ethetai",ethetai
6271         endif
6272         do m=1,ntheterm2
6273           do k=1,nsingle
6274             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
6275                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
6276                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
6277                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6278             ethetai=ethetai+sinkt(m)*aux
6279             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6280             dephii=dephii+k*sinkt(m)* &
6281                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
6282                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6283             dephii1=dephii1+k*sinkt(m)* &
6284                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
6285                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6286             if (lprn) &
6287             write (iout,*) "m",m," k",k," bbthet", &
6288                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
6289                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
6290                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
6291                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6292           enddo
6293         enddo
6294         if (lprn) &
6295         write(iout,*) "ethetai",ethetai
6296         do m=1,ntheterm3
6297           do k=2,ndouble
6298             do l=1,k-1
6299               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6300                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
6301                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6302                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6303               ethetai=ethetai+sinkt(m)*aux
6304               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6305               dephii=dephii+l*sinkt(m)* &
6306                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
6307                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6308                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6309                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6310               dephii1=dephii1+(k-l)*sinkt(m)* &
6311                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6312                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6313                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
6314                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6315               if (lprn) then
6316               write (iout,*) "m",m," k",k," l",l," ffthet",&
6317                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6318                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
6319                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6320                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
6321                   " ethetai",ethetai
6322               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
6323                   cosph1ph2(k,l)*sinkt(m),&
6324                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6325               endif
6326             enddo
6327           enddo
6328         enddo
6329 10      continue
6330 !        lprn1=.true.
6331         if (lprn1) &
6332           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
6333          i,theta(i)*rad2deg,phii*rad2deg,&
6334          phii1*rad2deg,ethetai
6335 !        lprn1=.false.
6336         etheta=etheta+ethetai
6337         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6338                                     'ebend',i,ethetai
6339         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6340         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6341         gloc(nphi+i-2,icg)=wang*dethetai
6342       enddo
6343 !-----------thete constrains
6344 !      if (tor_mode.ne.2) then
6345
6346       return
6347       end subroutine ebend
6348 #endif
6349 #ifdef CRYST_SC
6350 !-----------------------------------------------------------------------------
6351       subroutine esc(escloc)
6352 ! Calculate the local energy of a side chain and its derivatives in the
6353 ! corresponding virtual-bond valence angles THETA and the spherical angles
6354 ! ALPHA and OMEGA.
6355 !
6356       use comm_sccalc
6357 !      implicit real*8 (a-h,o-z)
6358 !      include 'DIMENSIONS'
6359 !      include 'COMMON.GEO'
6360 !      include 'COMMON.LOCAL'
6361 !      include 'COMMON.VAR'
6362 !      include 'COMMON.INTERACT'
6363 !      include 'COMMON.DERIV'
6364 !      include 'COMMON.CHAIN'
6365 !      include 'COMMON.IOUNITS'
6366 !      include 'COMMON.NAMES'
6367 !      include 'COMMON.FFIELD'
6368 !      include 'COMMON.CONTROL'
6369       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
6370          ddersc0,ddummy,xtemp,temp
6371 !el      real(kind=8) :: time11,time12,time112,theti
6372       real(kind=8) :: escloc,delta
6373 !el      integer :: it,nlobit
6374 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6375 !el local variables
6376       integer :: i,k
6377       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
6378        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6379       delta=0.02d0*pi
6380       escloc=0.0D0
6381 !     write (iout,'(a)') 'ESC'
6382       do i=loc_start,loc_end
6383         it=itype(i,1)
6384         if (it.eq.ntyp1) cycle
6385         if (it.eq.10) goto 1
6386         nlobit=nlob(iabs(it))
6387 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
6388 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6389         theti=theta(i+1)-pipol
6390         x(1)=dtan(theti)
6391         x(2)=alph(i)
6392         x(3)=omeg(i)
6393
6394         if (x(2).gt.pi-delta) then
6395           xtemp(1)=x(1)
6396           xtemp(2)=pi-delta
6397           xtemp(3)=x(3)
6398           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6399           xtemp(2)=pi
6400           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6401           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
6402               escloci,dersc(2))
6403           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6404               ddersc0(1),dersc(1))
6405           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
6406               ddersc0(3),dersc(3))
6407           xtemp(2)=pi-delta
6408           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6409           xtemp(2)=pi
6410           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6411           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6412                   dersc0(2),esclocbi,dersc02)
6413           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6414                   dersc12,dersc01)
6415           call splinthet(x(2),0.5d0*delta,ss,ssd)
6416           dersc0(1)=dersc01
6417           dersc0(2)=dersc02
6418           dersc0(3)=0.0d0
6419           do k=1,3
6420             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6421           enddo
6422           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6423 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6424 !    &             esclocbi,ss,ssd
6425           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6426 !         escloci=esclocbi
6427 !         write (iout,*) escloci
6428         else if (x(2).lt.delta) then
6429           xtemp(1)=x(1)
6430           xtemp(2)=delta
6431           xtemp(3)=x(3)
6432           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6433           xtemp(2)=0.0d0
6434           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6435           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6436               escloci,dersc(2))
6437           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6438               ddersc0(1),dersc(1))
6439           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6440               ddersc0(3),dersc(3))
6441           xtemp(2)=delta
6442           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6443           xtemp(2)=0.0d0
6444           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6445           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6446                   dersc0(2),esclocbi,dersc02)
6447           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6448                   dersc12,dersc01)
6449           dersc0(1)=dersc01
6450           dersc0(2)=dersc02
6451           dersc0(3)=0.0d0
6452           call splinthet(x(2),0.5d0*delta,ss,ssd)
6453           do k=1,3
6454             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6455           enddo
6456           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6457 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6458 !    &             esclocbi,ss,ssd
6459           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6460 !         write (iout,*) escloci
6461         else
6462           call enesc(x,escloci,dersc,ddummy,.false.)
6463         endif
6464
6465         escloc=escloc+escloci
6466         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6467            'escloc',i,escloci
6468 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6469
6470         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6471          wscloc*dersc(1)
6472         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6473         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6474     1   continue
6475       enddo
6476       return
6477       end subroutine esc
6478 !-----------------------------------------------------------------------------
6479       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6480
6481       use comm_sccalc
6482 !      implicit real*8 (a-h,o-z)
6483 !      include 'DIMENSIONS'
6484 !      include 'COMMON.GEO'
6485 !      include 'COMMON.LOCAL'
6486 !      include 'COMMON.IOUNITS'
6487 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6488       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6489       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6490       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6491       real(kind=8) :: escloci
6492       logical :: mixed
6493 !el local variables
6494       integer :: j,iii,l,k !el,it,nlobit
6495       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6496 !el       time11,time12,time112
6497 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6498         escloc_i=0.0D0
6499         do j=1,3
6500           dersc(j)=0.0D0
6501           if (mixed) ddersc(j)=0.0d0
6502         enddo
6503         x3=x(3)
6504
6505 ! Because of periodicity of the dependence of the SC energy in omega we have
6506 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6507 ! To avoid underflows, first compute & store the exponents.
6508
6509         do iii=-1,1
6510
6511           x(3)=x3+iii*dwapi
6512
6513           do j=1,nlobit
6514             do k=1,3
6515               z(k)=x(k)-censc(k,j,it)
6516             enddo
6517             do k=1,3
6518               Axk=0.0D0
6519               do l=1,3
6520                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6521               enddo
6522               Ax(k,j,iii)=Axk
6523             enddo
6524             expfac=0.0D0
6525             do k=1,3
6526               expfac=expfac+Ax(k,j,iii)*z(k)
6527             enddo
6528             contr(j,iii)=expfac
6529           enddo ! j
6530
6531         enddo ! iii
6532
6533         x(3)=x3
6534 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6535 ! subsequent NaNs and INFs in energy calculation.
6536 ! Find the largest exponent
6537         emin=contr(1,-1)
6538         do iii=-1,1
6539           do j=1,nlobit
6540             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6541           enddo
6542         enddo
6543         emin=0.5D0*emin
6544 !d      print *,'it=',it,' emin=',emin
6545
6546 ! Compute the contribution to SC energy and derivatives
6547         do iii=-1,1
6548
6549           do j=1,nlobit
6550 #ifdef OSF
6551             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6552             if(adexp.ne.adexp) adexp=1.0
6553             expfac=dexp(adexp)
6554 #else
6555             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6556 #endif
6557 !d          print *,'j=',j,' expfac=',expfac
6558             escloc_i=escloc_i+expfac
6559             do k=1,3
6560               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6561             enddo
6562             if (mixed) then
6563               do k=1,3,2
6564                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6565                   +gaussc(k,2,j,it))*expfac
6566               enddo
6567             endif
6568           enddo
6569
6570         enddo ! iii
6571
6572         dersc(1)=dersc(1)/cos(theti)**2
6573         ddersc(1)=ddersc(1)/cos(theti)**2
6574         ddersc(3)=ddersc(3)
6575
6576         escloci=-(dlog(escloc_i)-emin)
6577         do j=1,3
6578           dersc(j)=dersc(j)/escloc_i
6579         enddo
6580         if (mixed) then
6581           do j=1,3,2
6582             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6583           enddo
6584         endif
6585       return
6586       end subroutine enesc
6587 !-----------------------------------------------------------------------------
6588       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6589
6590       use comm_sccalc
6591 !      implicit real*8 (a-h,o-z)
6592 !      include 'DIMENSIONS'
6593 !      include 'COMMON.GEO'
6594 !      include 'COMMON.LOCAL'
6595 !      include 'COMMON.IOUNITS'
6596 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6597       real(kind=8),dimension(3) :: x,z,dersc
6598       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6599       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6600       real(kind=8) :: escloci,dersc12,emin
6601       logical :: mixed
6602 !el local varables
6603       integer :: j,k,l !el,it,nlobit
6604       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6605
6606       escloc_i=0.0D0
6607
6608       do j=1,3
6609         dersc(j)=0.0D0
6610       enddo
6611
6612       do j=1,nlobit
6613         do k=1,2
6614           z(k)=x(k)-censc(k,j,it)
6615         enddo
6616         z(3)=dwapi
6617         do k=1,3
6618           Axk=0.0D0
6619           do l=1,3
6620             Axk=Axk+gaussc(l,k,j,it)*z(l)
6621           enddo
6622           Ax(k,j)=Axk
6623         enddo
6624         expfac=0.0D0
6625         do k=1,3
6626           expfac=expfac+Ax(k,j)*z(k)
6627         enddo
6628         contr(j)=expfac
6629       enddo ! j
6630
6631 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6632 ! subsequent NaNs and INFs in energy calculation.
6633 ! Find the largest exponent
6634       emin=contr(1)
6635       do j=1,nlobit
6636         if (emin.gt.contr(j)) emin=contr(j)
6637       enddo
6638       emin=0.5D0*emin
6639
6640 ! Compute the contribution to SC energy and derivatives
6641
6642       dersc12=0.0d0
6643       do j=1,nlobit
6644         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6645         escloc_i=escloc_i+expfac
6646         do k=1,2
6647           dersc(k)=dersc(k)+Ax(k,j)*expfac
6648         enddo
6649         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6650                   +gaussc(1,2,j,it))*expfac
6651         dersc(3)=0.0d0
6652       enddo
6653
6654       dersc(1)=dersc(1)/cos(theti)**2
6655       dersc12=dersc12/cos(theti)**2
6656       escloci=-(dlog(escloc_i)-emin)
6657       do j=1,2
6658         dersc(j)=dersc(j)/escloc_i
6659       enddo
6660       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6661       return
6662       end subroutine enesc_bound
6663 #else
6664 !-----------------------------------------------------------------------------
6665       subroutine esc(escloc)
6666 ! Calculate the local energy of a side chain and its derivatives in the
6667 ! corresponding virtual-bond valence angles THETA and the spherical angles
6668 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6669 ! added by Urszula Kozlowska. 07/11/2007
6670 !
6671       use comm_sccalc
6672 !      implicit real*8 (a-h,o-z)
6673 !      include 'DIMENSIONS'
6674 !      include 'COMMON.GEO'
6675 !      include 'COMMON.LOCAL'
6676 !      include 'COMMON.VAR'
6677 !      include 'COMMON.SCROT'
6678 !      include 'COMMON.INTERACT'
6679 !      include 'COMMON.DERIV'
6680 !      include 'COMMON.CHAIN'
6681 !      include 'COMMON.IOUNITS'
6682 !      include 'COMMON.NAMES'
6683 !      include 'COMMON.FFIELD'
6684 !      include 'COMMON.CONTROL'
6685 !      include 'COMMON.VECTORS'
6686       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6687       real(kind=8),dimension(65) :: x
6688       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6689          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6690       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6691       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6692          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6693 !el local variables
6694       integer :: i,j,k !el,it,nlobit
6695       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6696 !el      real(kind=8) :: time11,time12,time112,theti
6697 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6698       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6699                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6700                    sumene1x,sumene2x,sumene3x,sumene4x,&
6701                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6702                    cosfac2xx,sinfac2yy
6703 #ifdef DEBUG
6704       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6705                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6706                    de_dt_num
6707 #endif
6708 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6709
6710       delta=0.02d0*pi
6711       escloc=0.0D0
6712       do i=loc_start,loc_end
6713         if (itype(i,1).eq.ntyp1) cycle
6714         costtab(i+1) =dcos(theta(i+1))
6715         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6716         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6717         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6718         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6719         cosfac=dsqrt(cosfac2)
6720         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6721         sinfac=dsqrt(sinfac2)
6722         it=iabs(itype(i,1))
6723         if (it.eq.10) goto 1
6724 !
6725 !  Compute the axes of tghe local cartesian coordinates system; store in
6726 !   x_prime, y_prime and z_prime
6727 !
6728         do j=1,3
6729           x_prime(j) = 0.00
6730           y_prime(j) = 0.00
6731           z_prime(j) = 0.00
6732         enddo
6733 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6734 !     &   dc_norm(3,i+nres)
6735         do j = 1,3
6736           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6737           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6738         enddo
6739         do j = 1,3
6740           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6741         enddo
6742 !       write (2,*) "i",i
6743 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6744 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6745 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6746 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6747 !      & " xy",scalar(x_prime(1),y_prime(1)),
6748 !      & " xz",scalar(x_prime(1),z_prime(1)),
6749 !      & " yy",scalar(y_prime(1),y_prime(1)),
6750 !      & " yz",scalar(y_prime(1),z_prime(1)),
6751 !      & " zz",scalar(z_prime(1),z_prime(1))
6752 !
6753 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6754 ! to local coordinate system. Store in xx, yy, zz.
6755 !
6756         xx=0.0d0
6757         yy=0.0d0
6758         zz=0.0d0
6759         do j = 1,3
6760           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6761           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6762           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6763         enddo
6764
6765         xxtab(i)=xx
6766         yytab(i)=yy
6767         zztab(i)=zz
6768 !
6769 ! Compute the energy of the ith side cbain
6770 !
6771 !        write (2,*) "xx",xx," yy",yy," zz",zz
6772         it=iabs(itype(i,1))
6773         do j = 1,65
6774           x(j) = sc_parmin(j,it)
6775         enddo
6776 #ifdef CHECK_COORD
6777 !c diagnostics - remove later
6778         xx1 = dcos(alph(2))
6779         yy1 = dsin(alph(2))*dcos(omeg(2))
6780         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6781         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6782           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6783           xx1,yy1,zz1
6784 !,"  --- ", xx_w,yy_w,zz_w
6785 ! end diagnostics
6786 #endif
6787         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6788          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6789          + x(10)*yy*zz
6790         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6791          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6792          + x(20)*yy*zz
6793         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6794          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6795          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6796          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6797          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6798          +x(40)*xx*yy*zz
6799         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6800          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6801          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6802          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6803          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6804          +x(60)*xx*yy*zz
6805         dsc_i   = 0.743d0+x(61)
6806         dp2_i   = 1.9d0+x(62)
6807         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6808                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6809         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6810                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6811         s1=(1+x(63))/(0.1d0 + dscp1)
6812         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6813         s2=(1+x(65))/(0.1d0 + dscp2)
6814         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6815         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6816       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6817 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6818 !     &   sumene4,
6819 !     &   dscp1,dscp2,sumene
6820 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6821         escloc = escloc + sumene
6822        if (energy_dec) write (2,*) "i",i," itype",itype(i,1)," it",it, &
6823         " escloc",sumene,escloc,it,itype(i,1)
6824 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6825 !     & ,zz,xx,yy
6826 !#define DEBUG
6827 #ifdef DEBUG
6828 !
6829 ! This section to check the numerical derivatives of the energy of ith side
6830 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6831 ! #define DEBUG in the code to turn it on.
6832 !
6833         write (2,*) "sumene               =",sumene
6834         aincr=1.0d-7
6835         xxsave=xx
6836         xx=xx+aincr
6837         write (2,*) xx,yy,zz
6838         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6839         de_dxx_num=(sumenep-sumene)/aincr
6840         xx=xxsave
6841         write (2,*) "xx+ sumene from enesc=",sumenep
6842         yysave=yy
6843         yy=yy+aincr
6844         write (2,*) xx,yy,zz
6845         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6846         de_dyy_num=(sumenep-sumene)/aincr
6847         yy=yysave
6848         write (2,*) "yy+ sumene from enesc=",sumenep
6849         zzsave=zz
6850         zz=zz+aincr
6851         write (2,*) xx,yy,zz
6852         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6853         de_dzz_num=(sumenep-sumene)/aincr
6854         zz=zzsave
6855         write (2,*) "zz+ sumene from enesc=",sumenep
6856         costsave=cost2tab(i+1)
6857         sintsave=sint2tab(i+1)
6858         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6859         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6860         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6861         de_dt_num=(sumenep-sumene)/aincr
6862         write (2,*) " t+ sumene from enesc=",sumenep
6863         cost2tab(i+1)=costsave
6864         sint2tab(i+1)=sintsave
6865 ! End of diagnostics section.
6866 #endif
6867 !
6868 ! Compute the gradient of esc
6869 !
6870 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6871         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6872         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6873         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6874         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6875         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6876         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6877         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6878         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6879         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6880            *(pom_s1/dscp1+pom_s16*dscp1**4)
6881         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6882            *(pom_s2/dscp2+pom_s26*dscp2**4)
6883         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6884         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6885         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6886         +x(40)*yy*zz
6887         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6888         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6889         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6890         +x(60)*yy*zz
6891         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6892               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6893               +(pom1+pom2)*pom_dx
6894 #ifdef DEBUG
6895         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6896 #endif
6897 !
6898         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6899         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6900         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6901         +x(40)*xx*zz
6902         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6903         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6904         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6905         +x(59)*zz**2 +x(60)*xx*zz
6906         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6907               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6908               +(pom1-pom2)*pom_dy
6909 #ifdef DEBUG
6910         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6911 #endif
6912 !
6913         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6914         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6915         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6916         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6917         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6918         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6919         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6920         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6921 #ifdef DEBUG
6922         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6923 #endif
6924 !
6925         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6926         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6927         +pom1*pom_dt1+pom2*pom_dt2
6928 #ifdef DEBUG
6929         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6930 #endif
6931 !
6932 !
6933        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6934        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6935        cosfac2xx=cosfac2*xx
6936        sinfac2yy=sinfac2*yy
6937        do k = 1,3
6938          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6939             vbld_inv(i+1)
6940          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6941             vbld_inv(i)
6942          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6943          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6944 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6945 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6946 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6947 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6948          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6949          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6950          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6951          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6952          dZZ_Ci1(k)=0.0d0
6953          dZZ_Ci(k)=0.0d0
6954          do j=1,3
6955            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6956            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6957            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6958            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6959          enddo
6960
6961          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6962          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6963          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6964          (z_prime(k)-zz*dC_norm(k,i+nres))
6965 !
6966          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6967          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6968        enddo
6969
6970        do k=1,3
6971          dXX_Ctab(k,i)=dXX_Ci(k)
6972          dXX_C1tab(k,i)=dXX_Ci1(k)
6973          dYY_Ctab(k,i)=dYY_Ci(k)
6974          dYY_C1tab(k,i)=dYY_Ci1(k)
6975          dZZ_Ctab(k,i)=dZZ_Ci(k)
6976          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6977          dXX_XYZtab(k,i)=dXX_XYZ(k)
6978          dYY_XYZtab(k,i)=dYY_XYZ(k)
6979          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6980        enddo
6981
6982        do k = 1,3
6983 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6984 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6985 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6986 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6987 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6988 !     &    dt_dci(k)
6989 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6990 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6991          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6992           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6993          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6994           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6995          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6996           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6997        enddo
6998 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6999 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7000
7001 ! to check gradient call subroutine check_grad
7002
7003     1 continue
7004       enddo
7005       return
7006       end subroutine esc
7007 !-----------------------------------------------------------------------------
7008       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
7009 !      implicit none
7010       real(kind=8),dimension(65) :: x
7011       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
7012         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7013
7014       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
7015         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
7016         + x(10)*yy*zz
7017       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
7018         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
7019         + x(20)*yy*zz
7020       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
7021         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
7022         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
7023         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
7024         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
7025         +x(40)*xx*yy*zz
7026       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
7027         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
7028         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
7029         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
7030         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
7031         +x(60)*xx*yy*zz
7032       dsc_i   = 0.743d0+x(61)
7033       dp2_i   = 1.9d0+x(62)
7034       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7035                 *(xx*cost2+yy*sint2))
7036       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7037                 *(xx*cost2-yy*sint2))
7038       s1=(1+x(63))/(0.1d0 + dscp1)
7039       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7040       s2=(1+x(65))/(0.1d0 + dscp2)
7041       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7042       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
7043        + (sumene4*cost2 +sumene2)*(s2+s2_6)
7044       enesc=sumene
7045       return
7046       end function enesc
7047 #endif
7048 !-----------------------------------------------------------------------------
7049       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7050 !
7051 ! This procedure calculates two-body contact function g(rij) and its derivative:
7052 !
7053 !           eps0ij                                     !       x < -1
7054 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7055 !            0                                         !       x > 1
7056 !
7057 ! where x=(rij-r0ij)/delta
7058 !
7059 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7060 !
7061 !      implicit none
7062       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
7063       real(kind=8) :: x,x2,x4,delta
7064 !     delta=0.02D0*r0ij
7065 !      delta=0.2D0*r0ij
7066       x=(rij-r0ij)/delta
7067       if (x.lt.-1.0D0) then
7068         fcont=eps0ij
7069         fprimcont=0.0D0
7070       else if (x.le.1.0D0) then
7071         x2=x*x
7072         x4=x2*x2
7073         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7074         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7075       else
7076         fcont=0.0D0
7077         fprimcont=0.0D0
7078       endif
7079       return
7080       end subroutine gcont
7081 !-----------------------------------------------------------------------------
7082       subroutine splinthet(theti,delta,ss,ssder)
7083 !      implicit real*8 (a-h,o-z)
7084 !      include 'DIMENSIONS'
7085 !      include 'COMMON.VAR'
7086 !      include 'COMMON.GEO'
7087       real(kind=8) :: theti,delta,ss,ssder
7088       real(kind=8) :: thetup,thetlow
7089       thetup=pi-delta
7090       thetlow=delta
7091       if (theti.gt.pipol) then
7092         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7093       else
7094         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7095         ssder=-ssder
7096       endif
7097       return
7098       end subroutine splinthet
7099 !-----------------------------------------------------------------------------
7100       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7101 !      implicit none
7102       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
7103       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7104       a1=fprim0*delta/(f1-f0)
7105       a2=3.0d0-2.0d0*a1
7106       a3=a1-2.0d0
7107       ksi=(x-x0)/delta
7108       ksi2=ksi*ksi
7109       ksi3=ksi2*ksi
7110       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7111       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7112       return
7113       end subroutine spline1
7114 !-----------------------------------------------------------------------------
7115       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7116 !      implicit none
7117       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
7118       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7119       ksi=(x-x0)/delta
7120       ksi2=ksi*ksi
7121       ksi3=ksi2*ksi
7122       a1=fprim0x*delta
7123       a2=3*(f1x-f0x)-2*fprim0x*delta
7124       a3=fprim0x*delta-2*(f1x-f0x)
7125       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7126       return
7127       end subroutine spline2
7128 !-----------------------------------------------------------------------------
7129 #ifdef CRYST_TOR
7130 !-----------------------------------------------------------------------------
7131       subroutine etor(etors,edihcnstr)
7132 !      implicit real*8 (a-h,o-z)
7133 !      include 'DIMENSIONS'
7134 !      include 'COMMON.VAR'
7135 !      include 'COMMON.GEO'
7136 !      include 'COMMON.LOCAL'
7137 !      include 'COMMON.TORSION'
7138 !      include 'COMMON.INTERACT'
7139 !      include 'COMMON.DERIV'
7140 !      include 'COMMON.CHAIN'
7141 !      include 'COMMON.NAMES'
7142 !      include 'COMMON.IOUNITS'
7143 !      include 'COMMON.FFIELD'
7144 !      include 'COMMON.TORCNSTR'
7145 !      include 'COMMON.CONTROL'
7146       real(kind=8) :: etors,edihcnstr
7147       logical :: lprn
7148 !el local variables
7149       integer :: i,j,
7150       real(kind=8) :: phii,fac,etors_ii
7151
7152 ! Set lprn=.true. for debugging
7153       lprn=.false.
7154 !      lprn=.true.
7155       etors=0.0D0
7156       do i=iphi_start,iphi_end
7157       etors_ii=0.0D0
7158         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7159             .or. itype(i,1).eq.ntyp1) cycle
7160         itori=itortyp(itype(i-2,1))
7161         itori1=itortyp(itype(i-1,1))
7162         phii=phi(i)
7163         gloci=0.0D0
7164 ! Proline-Proline pair is a special case...
7165         if (itori.eq.3 .and. itori1.eq.3) then
7166           if (phii.gt.-dwapi3) then
7167             cosphi=dcos(3*phii)
7168             fac=1.0D0/(1.0D0-cosphi)
7169             etorsi=v1(1,3,3)*fac
7170             etorsi=etorsi+etorsi
7171             etors=etors+etorsi-v1(1,3,3)
7172             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7173             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7174           endif
7175           do j=1,3
7176             v1ij=v1(j+1,itori,itori1)
7177             v2ij=v2(j+1,itori,itori1)
7178             cosphi=dcos(j*phii)
7179             sinphi=dsin(j*phii)
7180             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7181             if (energy_dec) etors_ii=etors_ii+ &
7182                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7183             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7184           enddo
7185         else
7186           do j=1,nterm_old
7187             v1ij=v1(j,itori,itori1)
7188             v2ij=v2(j,itori,itori1)
7189             cosphi=dcos(j*phii)
7190             sinphi=dsin(j*phii)
7191             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7192             if (energy_dec) etors_ii=etors_ii+ &
7193                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7194             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7195           enddo
7196         endif
7197         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7198              'etor',i,etors_ii
7199         if (lprn) &
7200         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7201         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7202         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7203         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7204 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7205       enddo
7206 ! 6/20/98 - dihedral angle constraints
7207       edihcnstr=0.0d0
7208       do i=1,ndih_constr
7209         itori=idih_constr(i)
7210         phii=phi(itori)
7211         difi=phii-phi0(i)
7212         if (difi.gt.drange(i)) then
7213           difi=difi-drange(i)
7214           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7215           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7216         else if (difi.lt.-drange(i)) then
7217           difi=difi+drange(i)
7218           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7219           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7220         endif
7221 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7222 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7223       enddo
7224 !      write (iout,*) 'edihcnstr',edihcnstr
7225       return
7226       end subroutine etor
7227 !-----------------------------------------------------------------------------
7228       subroutine etor_d(etors_d)
7229       real(kind=8) :: etors_d
7230       etors_d=0.0d0
7231       return
7232       end subroutine etor_d
7233 !-----------------------------------------------------------------------------
7234 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7235       subroutine e_modeller(ehomology_constr)
7236       real(kind=8) :: ehomology_constr
7237       ehomology_constr=0.0d0
7238       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7239       return
7240       end subroutine e_modeller
7241 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7242 #else
7243 !-----------------------------------------------------------------------------
7244       subroutine etor(etors)
7245 !      implicit real*8 (a-h,o-z)
7246 !      include 'DIMENSIONS'
7247 !      include 'COMMON.VAR'
7248 !      include 'COMMON.GEO'
7249 !      include 'COMMON.LOCAL'
7250 !      include 'COMMON.TORSION'
7251 !      include 'COMMON.INTERACT'
7252 !      include 'COMMON.DERIV'
7253 !      include 'COMMON.CHAIN'
7254 !      include 'COMMON.NAMES'
7255 !      include 'COMMON.IOUNITS'
7256 !      include 'COMMON.FFIELD'
7257 !      include 'COMMON.TORCNSTR'
7258 !      include 'COMMON.CONTROL'
7259       real(kind=8) :: etors,edihcnstr
7260       logical :: lprn
7261 !el local variables
7262       integer :: i,j,iblock,itori,itori1
7263       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7264                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
7265 ! Set lprn=.true. for debugging
7266       lprn=.false.
7267 !     lprn=.true.
7268       etors=0.0D0
7269       do i=iphi_start,iphi_end
7270         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7271              .or. itype(i-3,1).eq.ntyp1 &
7272              .or. itype(i,1).eq.ntyp1) cycle
7273         etors_ii=0.0D0
7274          if (iabs(itype(i,1)).eq.20) then
7275          iblock=2
7276          else
7277          iblock=1
7278          endif
7279         itori=itortyp(itype(i-2,1))
7280         itori1=itortyp(itype(i-1,1))
7281         phii=phi(i)
7282         gloci=0.0D0
7283 ! Regular cosine and sine terms
7284         do j=1,nterm(itori,itori1,iblock)
7285           v1ij=v1(j,itori,itori1,iblock)
7286           v2ij=v2(j,itori,itori1,iblock)
7287           cosphi=dcos(j*phii)
7288           sinphi=dsin(j*phii)
7289           etors=etors+v1ij*cosphi+v2ij*sinphi
7290           if (energy_dec) etors_ii=etors_ii+ &
7291                      v1ij*cosphi+v2ij*sinphi
7292           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7293         enddo
7294 ! Lorentz terms
7295 !                         v1
7296 !  E = SUM ----------------------------------- - v1
7297 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7298 !
7299         cosphi=dcos(0.5d0*phii)
7300         sinphi=dsin(0.5d0*phii)
7301         do j=1,nlor(itori,itori1,iblock)
7302           vl1ij=vlor1(j,itori,itori1)
7303           vl2ij=vlor2(j,itori,itori1)
7304           vl3ij=vlor3(j,itori,itori1)
7305           pom=vl2ij*cosphi+vl3ij*sinphi
7306           pom1=1.0d0/(pom*pom+1.0d0)
7307           etors=etors+vl1ij*pom1
7308           if (energy_dec) etors_ii=etors_ii+ &
7309                      vl1ij*pom1
7310           pom=-pom*pom1*pom1
7311           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7312         enddo
7313 ! Subtract the constant term
7314         etors=etors-v0(itori,itori1,iblock)
7315           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7316                'etor',i,etors_ii-v0(itori,itori1,iblock)
7317         if (lprn) &
7318         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7319         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7320         (v1(j,itori,itori1,iblock),j=1,6),&
7321         (v2(j,itori,itori1,iblock),j=1,6)
7322         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7323 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7324       enddo
7325 ! 6/20/98 - dihedral angle constraints
7326       return
7327       end subroutine etor
7328 !C The rigorous attempt to derive energy function
7329 !-------------------------------------------------------------------------------------------
7330       subroutine etor_kcc(etors)
7331       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7332       real(kind=8) :: etors,glocig,glocit1,glocit2,sinthet1,&
7333        sinthet2,costhet1,costhet2,sint1t2,sint1t2n,phii,sinphi,cosphi,&
7334        sint1t2n1,sumvalc,gradvalct1,gradvalct2,sumvals,gradvalst1,&
7335        gradvalst2,etori
7336       logical lprn
7337       integer :: i,j,itori,itori1,nval,k,l
7338
7339       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7340       etors=0.0D0
7341       do i=iphi_start,iphi_end
7342 !C ANY TWO ARE DUMMY ATOMS in row CYCLE
7343 !c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7344 !c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7345 !c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7346         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7347            .or. itype(i,1).eq.ntyp1 .or. itype(i-3,1).eq.ntyp1) cycle
7348         itori=itortyp(itype(i-2,1))
7349         itori1=itortyp(itype(i-1,1))
7350         phii=phi(i)
7351         glocig=0.0D0
7352         glocit1=0.0d0
7353         glocit2=0.0d0
7354 !C to avoid multiple devision by 2
7355 !c        theti22=0.5d0*theta(i)
7356 !C theta 12 is the theta_1 /2
7357 !C theta 22 is theta_2 /2
7358 !c        theti12=0.5d0*theta(i-1)
7359 !C and appropriate sinus function
7360         sinthet1=dsin(theta(i-1))
7361         sinthet2=dsin(theta(i))
7362         costhet1=dcos(theta(i-1))
7363         costhet2=dcos(theta(i))
7364 !C to speed up lets store its mutliplication
7365         sint1t2=sinthet2*sinthet1
7366         sint1t2n=1.0d0
7367 !C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7368 !C +d_n*sin(n*gamma)) *
7369 !C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7370 !C we have two sum 1) Non-Chebyshev which is with n and gamma
7371         nval=nterm_kcc_Tb(itori,itori1)
7372         c1(0)=0.0d0
7373         c2(0)=0.0d0
7374         c1(1)=1.0d0
7375         c2(1)=1.0d0
7376         do j=2,nval
7377           c1(j)=c1(j-1)*costhet1
7378           c2(j)=c2(j-1)*costhet2
7379         enddo
7380         etori=0.0d0
7381
7382        do j=1,nterm_kcc(itori,itori1)
7383           cosphi=dcos(j*phii)
7384           sinphi=dsin(j*phii)
7385           sint1t2n1=sint1t2n
7386           sint1t2n=sint1t2n*sint1t2
7387           sumvalc=0.0d0
7388           gradvalct1=0.0d0
7389           gradvalct2=0.0d0
7390           do k=1,nval
7391             do l=1,nval
7392               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7393               gradvalct1=gradvalct1+ &
7394                 (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7395               gradvalct2=gradvalct2+ &
7396                 (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7397             enddo
7398           enddo
7399           gradvalct1=-gradvalct1*sinthet1
7400           gradvalct2=-gradvalct2*sinthet2
7401           sumvals=0.0d0
7402           gradvalst1=0.0d0
7403           gradvalst2=0.0d0
7404           do k=1,nval
7405             do l=1,nval
7406               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7407               gradvalst1=gradvalst1+ &
7408                 (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7409               gradvalst2=gradvalst2+ &
7410                 (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7411             enddo
7412           enddo
7413           gradvalst1=-gradvalst1*sinthet1
7414           gradvalst2=-gradvalst2*sinthet2
7415           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7416           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7417 !C glocig is the gradient local i site in gamma
7418           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7419 !C now gradient over theta_1
7420          glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)&
7421         +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7422          glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)&
7423         +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7424         enddo ! j
7425         etors=etors+etori
7426         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7427 !C derivative over theta1
7428         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7429 !C now derivative over theta2
7430         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7431         if (lprn) then
7432          write (iout,*) i-2,i-1,itype(i-2,1),itype(i-1,1),itori,itori1,&
7433             theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7434           write (iout,*) "c1",(c1(k),k=0,nval), &
7435          " c2",(c2(k),k=0,nval)
7436         endif
7437       enddo
7438       return
7439        end  subroutine etor_kcc
7440 !------------------------------------------------------------------------------
7441
7442         subroutine etor_constr(edihcnstr)
7443       real(kind=8) :: etors,edihcnstr
7444       logical :: lprn
7445 !el local variables
7446       integer :: i,j,iblock,itori,itori1
7447       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7448                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom,&
7449                    gaudih_i,gauder_i,s,cos_i,dexpcos_i
7450
7451       if (raw_psipred) then
7452         do i=idihconstr_start,idihconstr_end
7453           itori=idih_constr(i)
7454           phii=phi(itori)
7455           gaudih_i=vpsipred(1,i)
7456           gauder_i=0.0d0
7457           do j=1,2
7458             s = sdihed(j,i)
7459             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7460             dexpcos_i=dexp(-cos_i*cos_i)
7461             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7462           gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) &
7463                  *cos_i*dexpcos_i/s**2
7464           enddo
7465           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7466           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7467           if (energy_dec) &
7468           write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') &
7469           i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),&
7470           phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),&
7471           phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,&
7472           -wdihc*dlog(gaudih_i)
7473         enddo
7474       else
7475
7476       do i=idihconstr_start,idihconstr_end
7477         itori=idih_constr(i)
7478         phii=phi(itori)
7479         difi=pinorm(phii-phi0(i))
7480         if (difi.gt.drange(i)) then
7481           difi=difi-drange(i)
7482           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7483           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7484         else if (difi.lt.-drange(i)) then
7485           difi=difi+drange(i)
7486           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7487           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7488         else
7489           difi=0.0
7490         endif
7491       enddo
7492
7493       endif
7494
7495       return
7496
7497       end subroutine etor_constr
7498 !-----------------------------------------------------------------------------
7499       subroutine etor_d(etors_d)
7500 ! 6/23/01 Compute double torsional energy
7501 !      implicit real*8 (a-h,o-z)
7502 !      include 'DIMENSIONS'
7503 !      include 'COMMON.VAR'
7504 !      include 'COMMON.GEO'
7505 !      include 'COMMON.LOCAL'
7506 !      include 'COMMON.TORSION'
7507 !      include 'COMMON.INTERACT'
7508 !      include 'COMMON.DERIV'
7509 !      include 'COMMON.CHAIN'
7510 !      include 'COMMON.NAMES'
7511 !      include 'COMMON.IOUNITS'
7512 !      include 'COMMON.FFIELD'
7513 !      include 'COMMON.TORCNSTR'
7514       real(kind=8) :: etors_d,etors_d_ii
7515       logical :: lprn
7516 !el local variables
7517       integer :: i,j,k,l,itori,itori1,itori2,iblock
7518       real(kind=8) :: phii,phii1,gloci1,gloci2,&
7519                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
7520                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
7521                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
7522 ! Set lprn=.true. for debugging
7523       lprn=.false.
7524 !     lprn=.true.
7525       etors_d=0.0D0
7526 !      write(iout,*) "a tu??"
7527       do i=iphid_start,iphid_end
7528         etors_d_ii=0.0D0
7529         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7530             .or. itype(i-3,1).eq.ntyp1 &
7531             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
7532         itori=itortyp(itype(i-2,1))
7533         itori1=itortyp(itype(i-1,1))
7534         itori2=itortyp(itype(i,1))
7535         phii=phi(i)
7536         phii1=phi(i+1)
7537         gloci1=0.0D0
7538         gloci2=0.0D0
7539         iblock=1
7540         if (iabs(itype(i+1,1)).eq.20) iblock=2
7541
7542 ! Regular cosine and sine terms
7543         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7544           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7545           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7546           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7547           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7548           cosphi1=dcos(j*phii)
7549           sinphi1=dsin(j*phii)
7550           cosphi2=dcos(j*phii1)
7551           sinphi2=dsin(j*phii1)
7552           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
7553            v2cij*cosphi2+v2sij*sinphi2
7554           if (energy_dec) etors_d_ii=etors_d_ii+ &
7555            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7556           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7557           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7558         enddo
7559         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7560           do l=1,k-1
7561             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7562             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7563             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7564             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7565             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7566             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7567             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7568             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7569             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7570               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7571             if (energy_dec) etors_d_ii=etors_d_ii+ &
7572               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7573               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7574             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7575               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7576             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7577               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7578           enddo
7579         enddo
7580         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7581                             'etor_d',i,etors_d_ii
7582         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7583         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7584       enddo
7585       return
7586       end subroutine etor_d
7587 #endif
7588 !----------------------------------------------------------------------------
7589 !----------------------------------------------------------------------------
7590       subroutine e_modeller(ehomology_constr)
7591 !      implicit none
7592 !      include 'DIMENSIONS'
7593       use MD_data, only: iset
7594       real(kind=8) :: ehomology_constr
7595       integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7596       integer katy, odleglosci, test7
7597       real(kind=8) :: odleg, odleg2, odleg3, kat, kat2, kat3
7598       real(kind=8) :: Eval,Erot,min_odl
7599       real(kind=8),dimension(constr_homology) :: distance,distancek,godl,dih_diff,gdih, &
7600       gtheta,dscdiff, &
7601                 uscdiffk,guscdiff2,guscdiff3,&
7602                 theta_diff
7603
7604
7605 !
7606 !     FP - 30/10/2014 Temporary specifications for homology restraints
7607 !
7608       real(kind=8) :: utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,&
7609                       sgtheta
7610       real(kind=8), dimension (nres) :: guscdiff,usc_diff
7611       real(kind=8) :: sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,&
7612       sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,&
7613       betai,sum_sgodl,dij,max_template
7614 !      real(kind=8) :: dist,pinorm
7615 !
7616 !     include 'COMMON.SBRIDGE'
7617 !     include 'COMMON.CHAIN'
7618 !     include 'COMMON.GEO'
7619 !     include 'COMMON.DERIV'
7620 !     include 'COMMON.LOCAL'
7621 !     include 'COMMON.INTERACT'
7622 !     include 'COMMON.VAR'
7623 !     include 'COMMON.IOUNITS'
7624 !      include 'COMMON.MD'
7625 !     include 'COMMON.CONTROL'
7626 !     include 'COMMON.HOMOLOGY'
7627 !     include 'COMMON.QRESTR'
7628 !
7629 !     From subroutine Econstr_back
7630 !
7631 !     include 'COMMON.NAMES'
7632 !     include 'COMMON.TIME1'
7633 !
7634
7635
7636       do i=1,max_template
7637         distancek(i)=9999999.9
7638       enddo
7639
7640
7641       odleg=0.0d0
7642
7643 ! Pseudo-energy and gradient from homology restraints (MODELLER-like
7644 ! function)
7645 ! AL 5/2/14 - Introduce list of restraints
7646 !     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7647 #ifdef DEBUG
7648       write(iout,*) "------- dist restrs start -------"
7649 #endif
7650       do ii = link_start_homo,link_end_homo
7651          i = ires_homo(ii)
7652          j = jres_homo(ii)
7653          dij=dist(i,j)
7654 !        write (iout,*) "dij(",i,j,") =",dij
7655          nexl=0
7656          do k=1,constr_homology
7657 !           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7658            if(.not.l_homo(k,ii)) then
7659              nexl=nexl+1
7660              cycle
7661            endif
7662            distance(k)=odl(k,ii)-dij
7663 !          write (iout,*) "distance(",k,") =",distance(k)
7664 !
7665 !          For Gaussian-type Urestr
7666 !
7667            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7668 !          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7669 !          write (iout,*) "distancek(",k,") =",distancek(k)
7670 !          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7671 !
7672 !          For Lorentzian-type Urestr
7673 !
7674            if (waga_dist.lt.0.0d0) then
7675               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7676               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)* &
7677                           (distance(k)**2+sigma_odlir(k,ii)**2))
7678            endif
7679          enddo
7680
7681 !         min_odl=minval(distancek)
7682          if (nexl.gt.0) then
7683            min_odl=0.0d0
7684          else
7685            do kk=1,constr_homology
7686             if(l_homo(kk,ii)) then
7687               min_odl=distancek(kk)
7688               exit
7689             endif
7690            enddo
7691            do kk=1,constr_homology
7692             if (l_homo(kk,ii) .and. distancek(kk).lt.min_odl) &
7693                    min_odl=distancek(kk)
7694            enddo
7695          endif
7696
7697 !        write (iout,* )"min_odl",min_odl
7698 #ifdef DEBUG
7699          write (iout,*) "ij dij",i,j,dij
7700          write (iout,*) "distance",(distance(k),k=1,constr_homology)
7701          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7702          write (iout,* )"min_odl",min_odl
7703 #endif
7704 #ifdef OLDRESTR
7705          odleg2=0.0d0
7706 #else
7707          if (waga_dist.ge.0.0d0) then
7708            odleg2=nexl
7709          else
7710            odleg2=0.0d0
7711          endif
7712 #endif
7713          do k=1,constr_homology
7714 ! Nie wiem po co to liczycie jeszcze raz!
7715 !            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
7716 !     &              (2*(sigma_odl(i,j,k))**2))
7717            if(.not.l_homo(k,ii)) cycle
7718            if (waga_dist.ge.0.0d0) then
7719 !
7720 !          For Gaussian-type Urestr
7721 !
7722             godl(k)=dexp(-distancek(k)+min_odl)
7723             odleg2=odleg2+godl(k)
7724 !
7725 !          For Lorentzian-type Urestr
7726 !
7727            else
7728             odleg2=odleg2+distancek(k)
7729            endif
7730
7731 !cc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
7732 !cc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
7733 !cc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
7734 !cc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
7735
7736          enddo
7737 !        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7738 !        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7739 #ifdef DEBUG
7740          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7741          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7742 #endif
7743            if (waga_dist.ge.0.0d0) then
7744 !
7745 !          For Gaussian-type Urestr
7746 !
7747               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
7748 !
7749 !          For Lorentzian-type Urestr
7750 !
7751            else
7752               odleg=odleg+odleg2/constr_homology
7753            endif
7754 !
7755 !        write (iout,*) "odleg",odleg ! sum of -ln-s
7756 ! Gradient
7757 !
7758 !          For Gaussian-type Urestr
7759 !
7760          if (waga_dist.ge.0.0d0) sum_godl=odleg2
7761          sum_sgodl=0.0d0
7762          do k=1,constr_homology
7763 !            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7764 !     &           *waga_dist)+min_odl
7765 !          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7766 !
7767          if(.not.l_homo(k,ii)) cycle
7768          if (waga_dist.ge.0.0d0) then
7769 !          For Gaussian-type Urestr
7770 !
7771            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7772 !
7773 !          For Lorentzian-type Urestr
7774 !
7775          else
7776            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+ &
7777                 sigma_odlir(k,ii)**2)**2)
7778          endif
7779            sum_sgodl=sum_sgodl+sgodl
7780
7781 !            sgodl2=sgodl2+sgodl
7782 !      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7783 !      write(iout,*) "constr_homology=",constr_homology
7784 !      write(iout,*) i, j, k, "TEST K"
7785          enddo
7786 !         print *, "ok",iset
7787          if (waga_dist.ge.0.0d0) then
7788 !
7789 !          For Gaussian-type Urestr
7790 !
7791             grad_odl3=waga_homology(iset)*waga_dist &
7792                      *sum_sgodl/(sum_godl*dij)
7793 !         print *, "ok"
7794 !
7795 !          For Lorentzian-type Urestr
7796 !
7797          else
7798 ! Original grad expr modified by analogy w Gaussian-type Urestr grad
7799 !           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7800             grad_odl3=-waga_homology(iset)*waga_dist* &
7801                      sum_sgodl/(constr_homology*dij)
7802 !         print *, "ok2"
7803          endif
7804 !
7805 !        grad_odl3=sum_sgodl/(sum_godl*dij)
7806
7807
7808 !      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7809 !      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7810 !     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7811
7812 !cc      write(iout,*) godl, sgodl, grad_odl3
7813
7814 !          grad_odl=grad_odl+grad_odl3
7815
7816          do jik=1,3
7817             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7818 !cc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7819 !cc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7820 !cc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7821             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7822             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7823 !cc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7824 !cc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7825 !         if (i.eq.25.and.j.eq.27) then
7826 !         write(iout,*) "jik",jik,"i",i,"j",j
7827 !         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7828 !         write(iout,*) "grad_odl3",grad_odl3
7829 !         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7830 !         write(iout,*) "ggodl",ggodl
7831 !         write(iout,*) "ghpbc(",jik,i,")",
7832 !     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
7833 !     &                 ghpbc(jik,j)
7834 !         endif
7835          enddo
7836 !cc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7837 !cc     & dLOG(odleg2),"-odleg=", -odleg
7838
7839       enddo ! ii-loop for dist
7840 #ifdef DEBUG
7841       write(iout,*) "------- dist restrs end -------"
7842 !     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7843 !    &     waga_d.eq.1.0d0) call sum_gradient
7844 #endif
7845 ! Pseudo-energy and gradient from dihedral-angle restraints from
7846 ! homology templates
7847 !      write (iout,*) "End of distance loop"
7848 !      call flush(iout)
7849       kat=0.0d0
7850 !      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7851 #ifdef DEBUG
7852       write(iout,*) "------- dih restrs start -------"
7853       do i=idihconstr_start_homo,idihconstr_end_homo
7854         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
7855       enddo
7856 #endif
7857       do i=idihconstr_start_homo,idihconstr_end_homo
7858         kat2=0.0d0
7859 !        betai=beta(i,i+1,i+2,i+3)
7860         betai = phi(i)
7861 !       write (iout,*) "betai =",betai
7862         do k=1,constr_homology
7863           dih_diff(k)=pinorm(dih(k,i)-betai)
7864 !d          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
7865 !d     &                  ,sigma_dih(k,i)
7866 !          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
7867 !     &                                   -(6.28318-dih_diff(i,k))
7868 !          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
7869 !     &                                   6.28318+dih_diff(i,k)
7870 #ifdef OLD_DIHED
7871           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7872 #else
7873           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7874 #endif
7875 !         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
7876           gdih(k)=dexp(kat3)
7877           kat2=kat2+gdih(k)
7878 !          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
7879 !          write(*,*)""
7880         enddo
7881 !       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
7882 !       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
7883 #ifdef DEBUG
7884         write (iout,*) "i",i," betai",betai," kat2",kat2
7885         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
7886 #endif
7887         if (kat2.le.1.0d-14) cycle
7888         kat=kat-dLOG(kat2/constr_homology)
7889 !       write (iout,*) "kat",kat ! sum of -ln-s
7890
7891 !cc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
7892 !cc     & dLOG(kat2), "-kat=", -kat
7893
7894 ! ----------------------------------------------------------------------
7895 ! Gradient
7896 ! ----------------------------------------------------------------------
7897
7898         sum_gdih=kat2
7899         sum_sgdih=0.0d0
7900         do k=1,constr_homology
7901 #ifdef OLD_DIHED
7902           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
7903 #else
7904           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
7905 #endif
7906 !         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
7907           sum_sgdih=sum_sgdih+sgdih
7908         enddo
7909 !       grad_dih3=sum_sgdih/sum_gdih
7910         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
7911 !         print *, "ok3"
7912
7913 !      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
7914 !cc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
7915 !cc     & gloc(nphi+i-3,icg)
7916         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
7917 !        if (i.eq.25) then
7918 !        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
7919 !        endif
7920 !cc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
7921 !cc     & gloc(nphi+i-3,icg)
7922
7923       enddo ! i-loop for dih
7924 #ifdef DEBUG
7925       write(iout,*) "------- dih restrs end -------"
7926 #endif
7927
7928 ! Pseudo-energy and gradient for theta angle restraints from
7929 ! homology templates
7930 ! FP 01/15 - inserted from econstr_local_test.F, loop structure
7931 ! adapted
7932
7933 !
7934 !     For constr_homology reference structures (FP)
7935 !
7936 !     Uconst_back_tot=0.0d0
7937       Eval=0.0d0
7938       Erot=0.0d0
7939 !     Econstr_back legacy
7940       do i=1,nres
7941 !     do i=ithet_start,ithet_end
7942        dutheta(i)=0.0d0
7943       enddo
7944 !     do i=loc_start,loc_end
7945       do i=-1,nres
7946         do j=1,3
7947           duscdiff(j,i)=0.0d0
7948           duscdiffx(j,i)=0.0d0
7949         enddo
7950       enddo
7951 !
7952 !     do iref=1,nref
7953 !     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
7954 !     write (iout,*) "waga_theta",waga_theta
7955       if (waga_theta.gt.0.0d0) then
7956 #ifdef DEBUG
7957       write (iout,*) "usampl",usampl
7958       write(iout,*) "------- theta restrs start -------"
7959 !     do i=ithet_start,ithet_end
7960 !       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
7961 !     enddo
7962 #endif
7963 !     write (iout,*) "maxres",maxres,"nres",nres
7964
7965       do i=ithet_start,ithet_end
7966 !
7967 !     do i=1,nfrag_back
7968 !       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
7969 !
7970 ! Deviation of theta angles wrt constr_homology ref structures
7971 !
7972         utheta_i=0.0d0 ! argument of Gaussian for single k
7973         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7974 !       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
7975 !       over residues in a fragment
7976 !       write (iout,*) "theta(",i,")=",theta(i)
7977         do k=1,constr_homology
7978 !
7979 !         dtheta_i=theta(j)-thetaref(j,iref)
7980 !         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
7981           theta_diff(k)=thetatpl(k,i)-theta(i)
7982 !d          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
7983 !d     &                  ,sigma_theta(k,i)
7984
7985 !
7986           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
7987 !         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
7988           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
7989           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
7990 !         Gradient for single Gaussian restraint in subr Econstr_back
7991 !         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
7992 !
7993         enddo
7994 !       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
7995 !       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
7996
7997 !
7998 !         Gradient for multiple Gaussian restraint
7999         sum_gtheta=gutheta_i
8000         sum_sgtheta=0.0d0
8001         do k=1,constr_homology
8002 !        New generalized expr for multiple Gaussian from Econstr_back
8003          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
8004 !
8005 !        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
8006           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
8007         enddo
8008 !       Final value of gradient using same var as in Econstr_back
8009         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg) &
8010            +sum_sgtheta/sum_gtheta*waga_theta &
8011                     *waga_homology(iset)
8012 !         print *, "ok4"
8013
8014 !        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8015 !     &               *waga_homology(iset)
8016 !       dutheta(i)=sum_sgtheta/sum_gtheta
8017 !
8018 !       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8019         Eval=Eval-dLOG(gutheta_i/constr_homology)
8020 !       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8021 !       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8022 !       Uconst_back=Uconst_back+utheta(i)
8023       enddo ! (i-loop for theta)
8024 #ifdef DEBUG
8025       write(iout,*) "------- theta restrs end -------"
8026 #endif
8027       endif
8028 !
8029 ! Deviation of local SC geometry
8030 !
8031 ! Separation of two i-loops (instructed by AL - 11/3/2014)
8032 !
8033 !     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8034 !     write (iout,*) "waga_d",waga_d
8035
8036 #ifdef DEBUG
8037       write(iout,*) "------- SC restrs start -------"
8038       write (iout,*) "Initial duscdiff,duscdiffx"
8039       do i=loc_start,loc_end
8040         write (iout,*) i,(duscdiff(jik,i),jik=1,3), &
8041                       (duscdiffx(jik,i),jik=1,3)
8042       enddo
8043 #endif
8044       do i=loc_start,loc_end
8045         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8046         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8047 !       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8048 !       write(iout,*) "xxtab, yytab, zztab"
8049 !       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8050         do k=1,constr_homology
8051 !
8052           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8053 !                                    Original sign inverted for calc of gradients (s. Econstr_back)
8054           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8055           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8056 !         write(iout,*) "dxx, dyy, dzz"
8057 !d          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8058 !
8059           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8060 !         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8061 !         uscdiffk(k)=usc_diff(i)
8062           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8063 !          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8064 !     &       " guscdiff2",guscdiff2(k)
8065           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8066 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8067 !     &      xxref(j),yyref(j),zzref(j)
8068         enddo
8069 !
8070 !       Gradient
8071 !
8072 !       Generalized expression for multiple Gaussian acc to that for a single
8073 !       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8074 !
8075 !       Original implementation
8076 !       sum_guscdiff=guscdiff(i)
8077 !
8078 !       sum_sguscdiff=0.0d0
8079 !       do k=1,constr_homology
8080 !          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8081 !          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8082 !          sum_sguscdiff=sum_sguscdiff+sguscdiff
8083 !       enddo
8084 !
8085 !       Implementation of new expressions for gradient (Jan. 2015)
8086 !
8087 !       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8088         do k=1,constr_homology
8089 !
8090 !       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8091 !       before. Now the drivatives should be correct
8092 !
8093           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8094 !                                  Original sign inverted for calc of gradients (s. Econstr_back)
8095           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8096           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8097           sum_guscdiff=guscdiff2(k)* &!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8098                       sigma_d(k,i) ! for the grad wrt r'
8099 !         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8100
8101 !
8102 !         New implementation
8103          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8104          do jik=1,3
8105             duscdiff(jik,i-1)=duscdiff(jik,i-1)+ &
8106             sum_guscdiff*(dXX_C1tab(jik,i)*dxx+ &
8107             dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8108             duscdiff(jik,i)=duscdiff(jik,i)+ &
8109             sum_guscdiff*(dXX_Ctab(jik,i)*dxx+ &
8110             dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8111             duscdiffx(jik,i)=duscdiffx(jik,i)+ &
8112             sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+ &
8113             dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8114 !         print *, "ok5"
8115 !
8116 #ifdef DEBUG
8117 !             write(iout,*) "jik",jik,"i",i
8118              write(iout,*) "dxx, dyy, dzz"
8119              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8120              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8121             write(iout,*) "sum_sguscdiff",sum_guscdiff,waga_homology(iset),waga_d
8122             write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8123             write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8124              write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8125              write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8126              write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8127              write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8128              write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8129              write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8130              write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8131              write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8132             write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8133             write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8134 !            endif
8135 #endif
8136          enddo
8137         enddo
8138 !         print *, "ok6"
8139 !
8140 !       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8141 !        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8142 !
8143 !        write (iout,*) i," uscdiff",uscdiff(i)
8144 !
8145 ! Put together deviations from local geometry
8146
8147 !       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8148 !      &            wfrag_back(3,i,iset)*uscdiff(i)
8149         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8150 !       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8151 !       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8152 !       Uconst_back=Uconst_back+usc_diff(i)
8153 !
8154 !     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8155 !
8156 !     New implment: multiplied by sum_sguscdiff
8157 !
8158
8159       enddo ! (i-loop for dscdiff)
8160
8161 !      endif
8162
8163 #ifdef DEBUG
8164       write(iout,*) "------- SC restrs end -------"
8165         write (iout,*) "------ After SC loop in e_modeller ------"
8166         do i=loc_start,loc_end
8167          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8168          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8169         enddo
8170       if (waga_theta.eq.1.0d0) then
8171       write (iout,*) "in e_modeller after SC restr end: dutheta"
8172       do i=ithet_start,ithet_end
8173         write (iout,*) i,dutheta(i)
8174       enddo
8175       endif
8176       if (waga_d.eq.1.0d0) then
8177       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8178       do i=1,nres
8179         write (iout,*) i,(duscdiff(j,i),j=1,3)
8180         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8181       enddo
8182       endif
8183 #endif
8184
8185 ! Total energy from homology restraints
8186 #ifdef DEBUG
8187       write (iout,*) "odleg",odleg," kat",kat
8188 #endif
8189 !
8190 ! Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8191 !
8192 !     ehomology_constr=odleg+kat
8193 !
8194 !     For Lorentzian-type Urestr
8195 !
8196
8197       if (waga_dist.ge.0.0d0) then
8198 !
8199 !          For Gaussian-type Urestr
8200 !
8201         ehomology_constr=(waga_dist*odleg+waga_angle*kat+ &
8202                    waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8203 !     write (iout,*) "ehomology_constr=",ehomology_constr
8204 !         print *, "ok7"
8205       else
8206 !
8207 !          For Lorentzian-type Urestr
8208 !
8209         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+ &
8210                    waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8211 !     write (iout,*) "ehomology_constr=",ehomology_constr
8212          print *, "ok8"
8213       endif
8214 #ifdef DEBUG
8215       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat, &
8216       "Eval",waga_theta,eval, &
8217         "Erot",waga_d,Erot
8218       write (iout,*) "ehomology_constr",ehomology_constr
8219 #endif
8220       return
8221 !
8222 ! FP 01/15 end
8223 !
8224   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8225   747 format(a12,i4,i4,i4,f8.3,f8.3)
8226   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8227   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8228   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X, &
8229             f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8230       end subroutine e_modeller
8231
8232 !----------------------------------------------------------------------------
8233       subroutine ebend_kcc(etheta)
8234       logical lprn
8235       double precision thybt1(maxang_kcc),etheta
8236       integer :: i,iti,j,ihelp
8237       real (kind=8) :: sinthet,costhet,sumth1thyb,gradthybt1
8238 !C Set lprn=.true. for debugging
8239       lprn=energy_dec
8240 !c     lprn=.true.
8241 !C      print *,"wchodze kcc"
8242       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8243       etheta=0.0D0
8244       do i=ithet_start,ithet_end
8245 !c        print *,i,itype(i-1),itype(i),itype(i-2)
8246         if ((itype(i-1,1).eq.ntyp1).or.itype(i-2,1).eq.ntyp1 &
8247        .or.itype(i,1).eq.ntyp1) cycle
8248         iti=iabs(itortyp(itype(i-1,1)))
8249         sinthet=dsin(theta(i))
8250         costhet=dcos(theta(i))
8251         do j=1,nbend_kcc_Tb(iti)
8252           thybt1(j)=v1bend_chyb(j,iti)
8253         enddo
8254         sumth1thyb=v1bend_chyb(0,iti)+ &
8255          tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8256         if (lprn) write (iout,*) i-1,itype(i-1,1),iti,theta(i)*rad2deg,&
8257          sumth1thyb
8258         ihelp=nbend_kcc_Tb(iti)-1
8259         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8260         etheta=etheta+sumth1thyb
8261 !C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8262         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8263       enddo
8264       return
8265       end subroutine ebend_kcc
8266 !c------------
8267 !c-------------------------------------------------------------------------------------
8268       subroutine etheta_constr(ethetacnstr)
8269       real (kind=8) :: ethetacnstr,thetiii,difi
8270       integer :: i,itheta
8271       ethetacnstr=0.0d0
8272 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8273       do i=ithetaconstr_start,ithetaconstr_end
8274         itheta=itheta_constr(i)
8275         thetiii=theta(itheta)
8276         difi=pinorm(thetiii-theta_constr0(i))
8277         if (difi.gt.theta_drange(i)) then
8278           difi=difi-theta_drange(i)
8279           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8280           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
8281          +for_thet_constr(i)*difi**3
8282         else if (difi.lt.-drange(i)) then
8283           difi=difi+drange(i)
8284           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8285           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
8286           +for_thet_constr(i)*difi**3
8287         else
8288           difi=0.0
8289         endif
8290        if (energy_dec) then
8291         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",&
8292          i,itheta,rad2deg*thetiii,&
8293          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),&
8294          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,&
8295          gloc(itheta+nphi-2,icg)
8296         endif
8297       enddo
8298       return
8299       end subroutine etheta_constr
8300
8301 !-----------------------------------------------------------------------------
8302       subroutine eback_sc_corr(esccor)
8303 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
8304 !        conformational states; temporarily implemented as differences
8305 !        between UNRES torsional potentials (dependent on three types of
8306 !        residues) and the torsional potentials dependent on all 20 types
8307 !        of residues computed from AM1  energy surfaces of terminally-blocked
8308 !        amino-acid residues.
8309 !      implicit real*8 (a-h,o-z)
8310 !      include 'DIMENSIONS'
8311 !      include 'COMMON.VAR'
8312 !      include 'COMMON.GEO'
8313 !      include 'COMMON.LOCAL'
8314 !      include 'COMMON.TORSION'
8315 !      include 'COMMON.SCCOR'
8316 !      include 'COMMON.INTERACT'
8317 !      include 'COMMON.DERIV'
8318 !      include 'COMMON.CHAIN'
8319 !      include 'COMMON.NAMES'
8320 !      include 'COMMON.IOUNITS'
8321 !      include 'COMMON.FFIELD'
8322 !      include 'COMMON.CONTROL'
8323       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
8324                    cosphi,sinphi
8325       logical :: lprn
8326       integer :: i,interty,j,isccori,isccori1,intertyp
8327 ! Set lprn=.true. for debugging
8328       lprn=.false.
8329 !      lprn=.true.
8330 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8331       esccor=0.0D0
8332       do i=itau_start,itau_end
8333         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
8334         esccor_ii=0.0D0
8335         isccori=isccortyp(itype(i-2,1))
8336         isccori1=isccortyp(itype(i-1,1))
8337
8338 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8339         phii=phi(i)
8340         do intertyp=1,3 !intertyp
8341          esccor_ii=0.0D0
8342 !c Added 09 May 2012 (Adasko)
8343 !c  Intertyp means interaction type of backbone mainchain correlation:
8344 !   1 = SC...Ca...Ca...Ca
8345 !   2 = Ca...Ca...Ca...SC
8346 !   3 = SC...Ca...Ca...SCi
8347         gloci=0.0D0
8348         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
8349             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
8350             (itype(i-1,1).eq.ntyp1))) &
8351           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
8352            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
8353            .or.(itype(i,1).eq.ntyp1))) &
8354           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
8355             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
8356             (itype(i-3,1).eq.ntyp1)))) cycle
8357         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
8358         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
8359        cycle
8360        do j=1,nterm_sccor(isccori,isccori1)
8361           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8362           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8363           cosphi=dcos(j*tauangle(intertyp,i))
8364           sinphi=dsin(j*tauangle(intertyp,i))
8365           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
8366           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8367           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8368         enddo
8369         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
8370                                 'esccor',i,intertyp,esccor_ii
8371 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8372         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8373         if (lprn) &
8374         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
8375         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
8376         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
8377         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8378         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8379        enddo !intertyp
8380       enddo
8381
8382       return
8383       end subroutine eback_sc_corr
8384 !-----------------------------------------------------------------------------
8385       subroutine multibody(ecorr)
8386 ! This subroutine calculates multi-body contributions to energy following
8387 ! the idea of Skolnick et al. If side chains I and J make a contact and
8388 ! at the same time side chains I+1 and J+1 make a contact, an extra
8389 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8390 !      implicit real*8 (a-h,o-z)
8391 !      include 'DIMENSIONS'
8392 !      include 'COMMON.IOUNITS'
8393 !      include 'COMMON.DERIV'
8394 !      include 'COMMON.INTERACT'
8395 !      include 'COMMON.CONTACTS'
8396       real(kind=8),dimension(3) :: gx,gx1
8397       logical :: lprn
8398       real(kind=8) :: ecorr
8399       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
8400 ! Set lprn=.true. for debugging
8401       lprn=.false.
8402
8403       if (lprn) then
8404         write (iout,'(a)') 'Contact function values:'
8405         do i=nnt,nct-2
8406           write (iout,'(i2,20(1x,i2,f10.5))') &
8407               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8408         enddo
8409       endif
8410       ecorr=0.0D0
8411
8412 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8413 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8414       do i=nnt,nct
8415         do j=1,3
8416           gradcorr(j,i)=0.0D0
8417           gradxorr(j,i)=0.0D0
8418         enddo
8419       enddo
8420       do i=nnt,nct-2
8421
8422         DO ISHIFT = 3,4
8423
8424         i1=i+ishift
8425         num_conti=num_cont(i)
8426         num_conti1=num_cont(i1)
8427         do jj=1,num_conti
8428           j=jcont(jj,i)
8429           do kk=1,num_conti1
8430             j1=jcont(kk,i1)
8431             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8432 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8433 !d   &                   ' ishift=',ishift
8434 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8435 ! The system gains extra energy.
8436               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8437             endif   ! j1==j+-ishift
8438           enddo     ! kk
8439         enddo       ! jj
8440
8441         ENDDO ! ISHIFT
8442
8443       enddo         ! i
8444       return
8445       end subroutine multibody
8446 !-----------------------------------------------------------------------------
8447       real(kind=8) function esccorr(i,j,k,l,jj,kk)
8448 !      implicit real*8 (a-h,o-z)
8449 !      include 'DIMENSIONS'
8450 !      include 'COMMON.IOUNITS'
8451 !      include 'COMMON.DERIV'
8452 !      include 'COMMON.INTERACT'
8453 !      include 'COMMON.CONTACTS'
8454       real(kind=8),dimension(3) :: gx,gx1
8455       logical :: lprn
8456       integer :: i,j,k,l,jj,kk,m,ll
8457       real(kind=8) :: eij,ekl
8458       lprn=.false.
8459       eij=facont(jj,i)
8460       ekl=facont(kk,k)
8461 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8462 ! Calculate the multi-body contribution to energy.
8463 ! Calculate multi-body contributions to the gradient.
8464 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8465 !d   & k,l,(gacont(m,kk,k),m=1,3)
8466       do m=1,3
8467         gx(m) =ekl*gacont(m,jj,i)
8468         gx1(m)=eij*gacont(m,kk,k)
8469         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8470         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8471         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8472         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8473       enddo
8474       do m=i,j-1
8475         do ll=1,3
8476           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8477         enddo
8478       enddo
8479       do m=k,l-1
8480         do ll=1,3
8481           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8482         enddo
8483       enddo
8484       esccorr=-eij*ekl
8485       return
8486       end function esccorr
8487 !-----------------------------------------------------------------------------
8488       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8489 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8490 !      implicit real*8 (a-h,o-z)
8491 !      include 'DIMENSIONS'
8492 !      include 'COMMON.IOUNITS'
8493 #ifdef MPI
8494       include "mpif.h"
8495 !      integer :: maxconts !max_cont=maxconts  =nres/4
8496       integer,parameter :: max_dim=26
8497       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8498       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8499 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8500 !el      common /przechowalnia/ zapas
8501       integer :: status(MPI_STATUS_SIZE)
8502       integer,dimension((nres/4)*2) :: req !maxconts*2
8503       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
8504 #endif
8505 !      include 'COMMON.SETUP'
8506 !      include 'COMMON.FFIELD'
8507 !      include 'COMMON.DERIV'
8508 !      include 'COMMON.INTERACT'
8509 !      include 'COMMON.CONTACTS'
8510 !      include 'COMMON.CONTROL'
8511 !      include 'COMMON.LOCAL'
8512       real(kind=8),dimension(3) :: gx,gx1
8513       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
8514       logical :: lprn,ldone
8515 !el local variables
8516       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
8517               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
8518
8519 ! Set lprn=.true. for debugging
8520       lprn=.false.
8521 #ifdef MPI
8522 !      maxconts=nres/4
8523       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8524       n_corr=0
8525       n_corr1=0
8526       if (nfgtasks.le.1) goto 30
8527       if (lprn) then
8528         write (iout,'(a)') 'Contact function values before RECEIVE:'
8529         do i=nnt,nct-2
8530           write (iout,'(2i3,50(1x,i2,f5.2))') &
8531           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8532           j=1,num_cont_hb(i))
8533         enddo
8534       endif
8535       call flush(iout)
8536       do i=1,ntask_cont_from
8537         ncont_recv(i)=0
8538       enddo
8539       do i=1,ntask_cont_to
8540         ncont_sent(i)=0
8541       enddo
8542 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8543 !     & ntask_cont_to
8544 ! Make the list of contacts to send to send to other procesors
8545 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8546 !      call flush(iout)
8547       do i=iturn3_start,iturn3_end
8548 !        write (iout,*) "make contact list turn3",i," num_cont",
8549 !     &    num_cont_hb(i)
8550         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8551       enddo
8552       do i=iturn4_start,iturn4_end
8553 !        write (iout,*) "make contact list turn4",i," num_cont",
8554 !     &   num_cont_hb(i)
8555         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8556       enddo
8557       do ii=1,nat_sent
8558         i=iat_sent(ii)
8559 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8560 !     &    num_cont_hb(i)
8561         do j=1,num_cont_hb(i)
8562         do k=1,4
8563           jjc=jcont_hb(j,i)
8564           iproc=iint_sent_local(k,jjc,ii)
8565 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8566           if (iproc.gt.0) then
8567             ncont_sent(iproc)=ncont_sent(iproc)+1
8568             nn=ncont_sent(iproc)
8569             zapas(1,nn,iproc)=i
8570             zapas(2,nn,iproc)=jjc
8571             zapas(3,nn,iproc)=facont_hb(j,i)
8572             zapas(4,nn,iproc)=ees0p(j,i)
8573             zapas(5,nn,iproc)=ees0m(j,i)
8574             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8575             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8576             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8577             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8578             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8579             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8580             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8581             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8582             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8583             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8584             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8585             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8586             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8587             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8588             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8589             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8590             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8591             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8592             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8593             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8594             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8595           endif
8596         enddo
8597         enddo
8598       enddo
8599       if (lprn) then
8600       write (iout,*) &
8601         "Numbers of contacts to be sent to other processors",&
8602         (ncont_sent(i),i=1,ntask_cont_to)
8603       write (iout,*) "Contacts sent"
8604       do ii=1,ntask_cont_to
8605         nn=ncont_sent(ii)
8606         iproc=itask_cont_to(ii)
8607         write (iout,*) nn," contacts to processor",iproc,&
8608          " of CONT_TO_COMM group"
8609         do i=1,nn
8610           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8611         enddo
8612       enddo
8613       call flush(iout)
8614       endif
8615       CorrelType=477
8616       CorrelID=fg_rank+1
8617       CorrelType1=478
8618       CorrelID1=nfgtasks+fg_rank+1
8619       ireq=0
8620 ! Receive the numbers of needed contacts from other processors
8621       do ii=1,ntask_cont_from
8622         iproc=itask_cont_from(ii)
8623         ireq=ireq+1
8624         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8625           FG_COMM,req(ireq),IERR)
8626       enddo
8627 !      write (iout,*) "IRECV ended"
8628 !      call flush(iout)
8629 ! Send the number of contacts needed by other processors
8630       do ii=1,ntask_cont_to
8631         iproc=itask_cont_to(ii)
8632         ireq=ireq+1
8633         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8634           FG_COMM,req(ireq),IERR)
8635       enddo
8636 !      write (iout,*) "ISEND ended"
8637 !      write (iout,*) "number of requests (nn)",ireq
8638       call flush(iout)
8639       if (ireq.gt.0) &
8640         call MPI_Waitall(ireq,req,status_array,ierr)
8641 !      write (iout,*)
8642 !     &  "Numbers of contacts to be received from other processors",
8643 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8644 !      call flush(iout)
8645 ! Receive contacts
8646       ireq=0
8647       do ii=1,ntask_cont_from
8648         iproc=itask_cont_from(ii)
8649         nn=ncont_recv(ii)
8650 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8651 !     &   " of CONT_TO_COMM group"
8652         call flush(iout)
8653         if (nn.gt.0) then
8654           ireq=ireq+1
8655           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8656           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8657 !          write (iout,*) "ireq,req",ireq,req(ireq)
8658         endif
8659       enddo
8660 ! Send the contacts to processors that need them
8661       do ii=1,ntask_cont_to
8662         iproc=itask_cont_to(ii)
8663         nn=ncont_sent(ii)
8664 !        write (iout,*) nn," contacts to processor",iproc,
8665 !     &   " of CONT_TO_COMM group"
8666         if (nn.gt.0) then
8667           ireq=ireq+1
8668           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8669             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8670 !          write (iout,*) "ireq,req",ireq,req(ireq)
8671 !          do i=1,nn
8672 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8673 !          enddo
8674         endif
8675       enddo
8676 !      write (iout,*) "number of requests (contacts)",ireq
8677 !      write (iout,*) "req",(req(i),i=1,4)
8678 !      call flush(iout)
8679       if (ireq.gt.0) &
8680        call MPI_Waitall(ireq,req,status_array,ierr)
8681       do iii=1,ntask_cont_from
8682         iproc=itask_cont_from(iii)
8683         nn=ncont_recv(iii)
8684         if (lprn) then
8685         write (iout,*) "Received",nn," contacts from processor",iproc,&
8686          " of CONT_FROM_COMM group"
8687         call flush(iout)
8688         do i=1,nn
8689           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8690         enddo
8691         call flush(iout)
8692         endif
8693         do i=1,nn
8694           ii=zapas_recv(1,i,iii)
8695 ! Flag the received contacts to prevent double-counting
8696           jj=-zapas_recv(2,i,iii)
8697 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8698 !          call flush(iout)
8699           nnn=num_cont_hb(ii)+1
8700           num_cont_hb(ii)=nnn
8701           jcont_hb(nnn,ii)=jj
8702           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8703           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8704           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8705           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8706           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8707           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8708           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8709           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8710           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8711           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8712           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8713           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8714           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8715           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8716           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8717           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8718           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8719           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8720           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8721           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8722           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8723           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8724           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8725           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8726         enddo
8727       enddo
8728       call flush(iout)
8729       if (lprn) then
8730         write (iout,'(a)') 'Contact function values after receive:'
8731         do i=nnt,nct-2
8732           write (iout,'(2i3,50(1x,i3,f5.2))') &
8733           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8734           j=1,num_cont_hb(i))
8735         enddo
8736         call flush(iout)
8737       endif
8738    30 continue
8739 #endif
8740       if (lprn) then
8741         write (iout,'(a)') 'Contact function values:'
8742         do i=nnt,nct-2
8743           write (iout,'(2i3,50(1x,i3,f5.2))') &
8744           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8745           j=1,num_cont_hb(i))
8746         enddo
8747       endif
8748       ecorr=0.0D0
8749
8750 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8751 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8752 ! Remove the loop below after debugging !!!
8753       do i=nnt,nct
8754         do j=1,3
8755           gradcorr(j,i)=0.0D0
8756           gradxorr(j,i)=0.0D0
8757         enddo
8758       enddo
8759 ! Calculate the local-electrostatic correlation terms
8760       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8761         i1=i+1
8762         num_conti=num_cont_hb(i)
8763         num_conti1=num_cont_hb(i+1)
8764         do jj=1,num_conti
8765           j=jcont_hb(jj,i)
8766           jp=iabs(j)
8767           do kk=1,num_conti1
8768             j1=jcont_hb(kk,i1)
8769             jp1=iabs(j1)
8770 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
8771 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
8772             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8773                 .or. j.lt.0 .and. j1.gt.0) .and. &
8774                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8775 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8776 ! The system gains extra energy.
8777               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8778               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
8779                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8780               n_corr=n_corr+1
8781             else if (j1.eq.j) then
8782 ! Contacts I-J and I-(J+1) occur simultaneously.
8783 ! The system loses extra energy.
8784 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8785             endif
8786           enddo ! kk
8787           do kk=1,num_conti
8788             j1=jcont_hb(kk,i)
8789 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8790 !    &         ' jj=',jj,' kk=',kk
8791             if (j1.eq.j+1) then
8792 ! Contacts I-J and (I+1)-J occur simultaneously.
8793 ! The system loses extra energy.
8794 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8795             endif ! j1==j+1
8796           enddo ! kk
8797         enddo ! jj
8798       enddo ! i
8799       return
8800       end subroutine multibody_hb
8801 !-----------------------------------------------------------------------------
8802       subroutine add_hb_contact(ii,jj,itask)
8803 !      implicit real*8 (a-h,o-z)
8804 !      include "DIMENSIONS"
8805 !      include "COMMON.IOUNITS"
8806 !      include "COMMON.CONTACTS"
8807 !      integer,parameter :: maxconts=nres/4
8808       integer,parameter :: max_dim=26
8809       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8810 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8811 !      common /przechowalnia/ zapas
8812       integer :: i,j,ii,jj,iproc,nn,jjc
8813       integer,dimension(4) :: itask
8814 !      write (iout,*) "itask",itask
8815       do i=1,2
8816         iproc=itask(i)
8817         if (iproc.gt.0) then
8818           do j=1,num_cont_hb(ii)
8819             jjc=jcont_hb(j,ii)
8820 !            write (iout,*) "i",ii," j",jj," jjc",jjc
8821             if (jjc.eq.jj) then
8822               ncont_sent(iproc)=ncont_sent(iproc)+1
8823               nn=ncont_sent(iproc)
8824               zapas(1,nn,iproc)=ii
8825               zapas(2,nn,iproc)=jjc
8826               zapas(3,nn,iproc)=facont_hb(j,ii)
8827               zapas(4,nn,iproc)=ees0p(j,ii)
8828               zapas(5,nn,iproc)=ees0m(j,ii)
8829               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8830               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8831               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8832               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8833               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8834               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8835               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8836               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8837               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8838               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8839               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8840               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8841               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8842               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8843               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8844               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8845               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8846               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8847               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8848               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8849               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8850               exit
8851             endif
8852           enddo
8853         endif
8854       enddo
8855       return
8856       end subroutine add_hb_contact
8857 !-----------------------------------------------------------------------------
8858       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
8859 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8860 !      implicit real*8 (a-h,o-z)
8861 !      include 'DIMENSIONS'
8862 !      include 'COMMON.IOUNITS'
8863       integer,parameter :: max_dim=70
8864 #ifdef MPI
8865       include "mpif.h"
8866 !      integer :: maxconts !max_cont=maxconts=nres/4
8867       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8868       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8869 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8870 !      common /przechowalnia/ zapas
8871       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
8872         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
8873         ierr,iii,nnn
8874 #endif
8875 !      include 'COMMON.SETUP'
8876 !      include 'COMMON.FFIELD'
8877 !      include 'COMMON.DERIV'
8878 !      include 'COMMON.LOCAL'
8879 !      include 'COMMON.INTERACT'
8880 !      include 'COMMON.CONTACTS'
8881 !      include 'COMMON.CHAIN'
8882 !      include 'COMMON.CONTROL'
8883       real(kind=8),dimension(3) :: gx,gx1
8884       integer,dimension(nres) :: num_cont_hb_old
8885       logical :: lprn,ldone
8886 !EL      double precision eello4,eello5,eelo6,eello_turn6
8887 !EL      external eello4,eello5,eello6,eello_turn6
8888 !el local variables
8889       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
8890               j1,jp1,i1,num_conti1
8891       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
8892       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
8893
8894 ! Set lprn=.true. for debugging
8895       lprn=.false.
8896       eturn6=0.0d0
8897 #ifdef MPI
8898 !      maxconts=nres/4
8899       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8900       do i=1,nres
8901         num_cont_hb_old(i)=num_cont_hb(i)
8902       enddo
8903       n_corr=0
8904       n_corr1=0
8905       if (nfgtasks.le.1) goto 30
8906       if (lprn) then
8907         write (iout,'(a)') 'Contact function values before RECEIVE:'
8908         do i=nnt,nct-2
8909           write (iout,'(2i3,50(1x,i2,f5.2))') &
8910           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8911           j=1,num_cont_hb(i))
8912         enddo
8913       endif
8914       call flush(iout)
8915       do i=1,ntask_cont_from
8916         ncont_recv(i)=0
8917       enddo
8918       do i=1,ntask_cont_to
8919         ncont_sent(i)=0
8920       enddo
8921 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8922 !     & ntask_cont_to
8923 ! Make the list of contacts to send to send to other procesors
8924       do i=iturn3_start,iturn3_end
8925 !        write (iout,*) "make contact list turn3",i," num_cont",
8926 !     &    num_cont_hb(i)
8927         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8928       enddo
8929       do i=iturn4_start,iturn4_end
8930 !        write (iout,*) "make contact list turn4",i," num_cont",
8931 !     &   num_cont_hb(i)
8932         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8933       enddo
8934       do ii=1,nat_sent
8935         i=iat_sent(ii)
8936 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8937 !     &    num_cont_hb(i)
8938         do j=1,num_cont_hb(i)
8939         do k=1,4
8940           jjc=jcont_hb(j,i)
8941           iproc=iint_sent_local(k,jjc,ii)
8942 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8943           if (iproc.ne.0) then
8944             ncont_sent(iproc)=ncont_sent(iproc)+1
8945             nn=ncont_sent(iproc)
8946             zapas(1,nn,iproc)=i
8947             zapas(2,nn,iproc)=jjc
8948             zapas(3,nn,iproc)=d_cont(j,i)
8949             ind=3
8950             do kk=1,3
8951               ind=ind+1
8952               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8953             enddo
8954             do kk=1,2
8955               do ll=1,2
8956                 ind=ind+1
8957                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8958               enddo
8959             enddo
8960             do jj=1,5
8961               do kk=1,3
8962                 do ll=1,2
8963                   do mm=1,2
8964                     ind=ind+1
8965                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8966                   enddo
8967                 enddo
8968               enddo
8969             enddo
8970           endif
8971         enddo
8972         enddo
8973       enddo
8974       if (lprn) then
8975       write (iout,*) &
8976         "Numbers of contacts to be sent to other processors",&
8977         (ncont_sent(i),i=1,ntask_cont_to)
8978       write (iout,*) "Contacts sent"
8979       do ii=1,ntask_cont_to
8980         nn=ncont_sent(ii)
8981         iproc=itask_cont_to(ii)
8982         write (iout,*) nn," contacts to processor",iproc,&
8983          " of CONT_TO_COMM group"
8984         do i=1,nn
8985           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8986         enddo
8987       enddo
8988       call flush(iout)
8989       endif
8990       CorrelType=477
8991       CorrelID=fg_rank+1
8992       CorrelType1=478
8993       CorrelID1=nfgtasks+fg_rank+1
8994       ireq=0
8995 ! Receive the numbers of needed contacts from other processors
8996       do ii=1,ntask_cont_from
8997         iproc=itask_cont_from(ii)
8998         ireq=ireq+1
8999         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
9000           FG_COMM,req(ireq),IERR)
9001       enddo
9002 !      write (iout,*) "IRECV ended"
9003 !      call flush(iout)
9004 ! Send the number of contacts needed by other processors
9005       do ii=1,ntask_cont_to
9006         iproc=itask_cont_to(ii)
9007         ireq=ireq+1
9008         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
9009           FG_COMM,req(ireq),IERR)
9010       enddo
9011 !      write (iout,*) "ISEND ended"
9012 !      write (iout,*) "number of requests (nn)",ireq
9013       call flush(iout)
9014       if (ireq.gt.0) &
9015         call MPI_Waitall(ireq,req,status_array,ierr)
9016 !      write (iout,*)
9017 !     &  "Numbers of contacts to be received from other processors",
9018 !     &  (ncont_recv(i),i=1,ntask_cont_from)
9019 !      call flush(iout)
9020 ! Receive contacts
9021       ireq=0
9022       do ii=1,ntask_cont_from
9023         iproc=itask_cont_from(ii)
9024         nn=ncont_recv(ii)
9025 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9026 !     &   " of CONT_TO_COMM group"
9027         call flush(iout)
9028         if (nn.gt.0) then
9029           ireq=ireq+1
9030           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
9031           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9032 !          write (iout,*) "ireq,req",ireq,req(ireq)
9033         endif
9034       enddo
9035 ! Send the contacts to processors that need them
9036       do ii=1,ntask_cont_to
9037         iproc=itask_cont_to(ii)
9038         nn=ncont_sent(ii)
9039 !        write (iout,*) nn," contacts to processor",iproc,
9040 !     &   " of CONT_TO_COMM group"
9041         if (nn.gt.0) then
9042           ireq=ireq+1
9043           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
9044             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9045 !          write (iout,*) "ireq,req",ireq,req(ireq)
9046 !          do i=1,nn
9047 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9048 !          enddo
9049         endif
9050       enddo
9051 !      write (iout,*) "number of requests (contacts)",ireq
9052 !      write (iout,*) "req",(req(i),i=1,4)
9053 !      call flush(iout)
9054       if (ireq.gt.0) &
9055        call MPI_Waitall(ireq,req,status_array,ierr)
9056       do iii=1,ntask_cont_from
9057         iproc=itask_cont_from(iii)
9058         nn=ncont_recv(iii)
9059         if (lprn) then
9060         write (iout,*) "Received",nn," contacts from processor",iproc,&
9061          " of CONT_FROM_COMM group"
9062         call flush(iout)
9063         do i=1,nn
9064           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9065         enddo
9066         call flush(iout)
9067         endif
9068         do i=1,nn
9069           ii=zapas_recv(1,i,iii)
9070 ! Flag the received contacts to prevent double-counting
9071           jj=-zapas_recv(2,i,iii)
9072 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9073 !          call flush(iout)
9074           nnn=num_cont_hb(ii)+1
9075           num_cont_hb(ii)=nnn
9076           jcont_hb(nnn,ii)=jj
9077           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9078           ind=3
9079           do kk=1,3
9080             ind=ind+1
9081             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9082           enddo
9083           do kk=1,2
9084             do ll=1,2
9085               ind=ind+1
9086               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9087             enddo
9088           enddo
9089           do jj=1,5
9090             do kk=1,3
9091               do ll=1,2
9092                 do mm=1,2
9093                   ind=ind+1
9094                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9095                 enddo
9096               enddo
9097             enddo
9098           enddo
9099         enddo
9100       enddo
9101       call flush(iout)
9102       if (lprn) then
9103         write (iout,'(a)') 'Contact function values after receive:'
9104         do i=nnt,nct-2
9105           write (iout,'(2i3,50(1x,i3,5f6.3))') &
9106           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
9107           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9108         enddo
9109         call flush(iout)
9110       endif
9111    30 continue
9112 #endif
9113       if (lprn) then
9114         write (iout,'(a)') 'Contact function values:'
9115         do i=nnt,nct-2
9116           write (iout,'(2i3,50(1x,i2,5f6.3))') &
9117           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
9118           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9119         enddo
9120       endif
9121       ecorr=0.0D0
9122       ecorr5=0.0d0
9123       ecorr6=0.0d0
9124
9125 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
9126 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
9127 ! Remove the loop below after debugging !!!
9128       do i=nnt,nct
9129         do j=1,3
9130           gradcorr(j,i)=0.0D0
9131           gradxorr(j,i)=0.0D0
9132         enddo
9133       enddo
9134 ! Calculate the dipole-dipole interaction energies
9135       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9136       do i=iatel_s,iatel_e+1
9137         num_conti=num_cont_hb(i)
9138         do jj=1,num_conti
9139           j=jcont_hb(jj,i)
9140 #ifdef MOMENT
9141           call dipole(i,j,jj)
9142 #endif
9143         enddo
9144       enddo
9145       endif
9146 ! Calculate the local-electrostatic correlation terms
9147 !                write (iout,*) "gradcorr5 in eello5 before loop"
9148 !                do iii=1,nres
9149 !                  write (iout,'(i5,3f10.5)')
9150 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9151 !                enddo
9152       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9153 !        write (iout,*) "corr loop i",i
9154         i1=i+1
9155         num_conti=num_cont_hb(i)
9156         num_conti1=num_cont_hb(i+1)
9157         do jj=1,num_conti
9158           j=jcont_hb(jj,i)
9159           jp=iabs(j)
9160           do kk=1,num_conti1
9161             j1=jcont_hb(kk,i1)
9162             jp1=iabs(j1)
9163 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9164 !     &         ' jj=',jj,' kk=',kk
9165 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
9166             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
9167                 .or. j.lt.0 .and. j1.gt.0) .and. &
9168                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9169 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9170 ! The system gains extra energy.
9171               n_corr=n_corr+1
9172               sqd1=dsqrt(d_cont(jj,i))
9173               sqd2=dsqrt(d_cont(kk,i1))
9174               sred_geom = sqd1*sqd2
9175               IF (sred_geom.lt.cutoff_corr) THEN
9176                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
9177                   ekont,fprimcont)
9178 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9179 !d     &         ' jj=',jj,' kk=',kk
9180                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9181                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9182                 do l=1,3
9183                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9184                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9185                 enddo
9186                 n_corr1=n_corr1+1
9187 !d               write (iout,*) 'sred_geom=',sred_geom,
9188 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
9189 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9190 !d               write (iout,*) "g_contij",g_contij
9191 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9192 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9193                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9194                 if (wcorr4.gt.0.0d0) &
9195                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9196                   if (energy_dec.and.wcorr4.gt.0.0d0) &
9197                        write (iout,'(a6,4i5,0pf7.3)') &
9198                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9199 !                write (iout,*) "gradcorr5 before eello5"
9200 !                do iii=1,nres
9201 !                  write (iout,'(i5,3f10.5)')
9202 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9203 !                enddo
9204                 if (wcorr5.gt.0.0d0) &
9205                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9206 !                write (iout,*) "gradcorr5 after eello5"
9207 !                do iii=1,nres
9208 !                  write (iout,'(i5,3f10.5)')
9209 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9210 !                enddo
9211                   if (energy_dec.and.wcorr5.gt.0.0d0) &
9212                        write (iout,'(a6,4i5,0pf7.3)') &
9213                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9214 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9215 !d                write(2,*)'ijkl',i,jp,i+1,jp1
9216                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
9217                      .or. wturn6.eq.0.0d0))then
9218 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9219                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9220                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
9221                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9222 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9223 !d     &            'ecorr6=',ecorr6
9224 !d                write (iout,'(4e15.5)') sred_geom,
9225 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9226 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9227 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9228                 else if (wturn6.gt.0.0d0 &
9229                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9230 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9231                   eturn6=eturn6+eello_turn6(i,jj,kk)
9232                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
9233                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9234 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
9235                 endif
9236               ENDIF
9237 1111          continue
9238             endif
9239           enddo ! kk
9240         enddo ! jj
9241       enddo ! i
9242       do i=1,nres
9243         num_cont_hb(i)=num_cont_hb_old(i)
9244       enddo
9245 !                write (iout,*) "gradcorr5 in eello5"
9246 !                do iii=1,nres
9247 !                  write (iout,'(i5,3f10.5)')
9248 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9249 !                enddo
9250       return
9251       end subroutine multibody_eello
9252 !-----------------------------------------------------------------------------
9253       subroutine add_hb_contact_eello(ii,jj,itask)
9254 !      implicit real*8 (a-h,o-z)
9255 !      include "DIMENSIONS"
9256 !      include "COMMON.IOUNITS"
9257 !      include "COMMON.CONTACTS"
9258 !      integer,parameter :: maxconts=nres/4
9259       integer,parameter :: max_dim=70
9260       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
9261 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
9262 !      common /przechowalnia/ zapas
9263
9264       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
9265       integer,dimension(4) ::itask
9266 !      write (iout,*) "itask",itask
9267       do i=1,2
9268         iproc=itask(i)
9269         if (iproc.gt.0) then
9270           do j=1,num_cont_hb(ii)
9271             jjc=jcont_hb(j,ii)
9272 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9273             if (jjc.eq.jj) then
9274               ncont_sent(iproc)=ncont_sent(iproc)+1
9275               nn=ncont_sent(iproc)
9276               zapas(1,nn,iproc)=ii
9277               zapas(2,nn,iproc)=jjc
9278               zapas(3,nn,iproc)=d_cont(j,ii)
9279               ind=3
9280               do kk=1,3
9281                 ind=ind+1
9282                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9283               enddo
9284               do kk=1,2
9285                 do ll=1,2
9286                   ind=ind+1
9287                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9288                 enddo
9289               enddo
9290               do jj=1,5
9291                 do kk=1,3
9292                   do ll=1,2
9293                     do mm=1,2
9294                       ind=ind+1
9295                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9296                     enddo
9297                   enddo
9298                 enddo
9299               enddo
9300               exit
9301             endif
9302           enddo
9303         endif
9304       enddo
9305       return
9306       end subroutine add_hb_contact_eello
9307 !-----------------------------------------------------------------------------
9308       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9309 !      implicit real*8 (a-h,o-z)
9310 !      include 'DIMENSIONS'
9311 !      include 'COMMON.IOUNITS'
9312 !      include 'COMMON.DERIV'
9313 !      include 'COMMON.INTERACT'
9314 !      include 'COMMON.CONTACTS'
9315       real(kind=8),dimension(3) :: gx,gx1
9316       logical :: lprn
9317 !el local variables
9318       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
9319       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
9320                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
9321                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
9322                    rlocshield
9323
9324       lprn=.false.
9325       eij=facont_hb(jj,i)
9326       ekl=facont_hb(kk,k)
9327       ees0pij=ees0p(jj,i)
9328       ees0pkl=ees0p(kk,k)
9329       ees0mij=ees0m(jj,i)
9330       ees0mkl=ees0m(kk,k)
9331       ekont=eij*ekl
9332       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9333 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9334 ! Following 4 lines for diagnostics.
9335 !d    ees0pkl=0.0D0
9336 !d    ees0pij=1.0D0
9337 !d    ees0mkl=0.0D0
9338 !d    ees0mij=1.0D0
9339 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9340 !     & 'Contacts ',i,j,
9341 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9342 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9343 !     & 'gradcorr_long'
9344 ! Calculate the multi-body contribution to energy.
9345 !      ecorr=ecorr+ekont*ees
9346 ! Calculate multi-body contributions to the gradient.
9347       coeffpees0pij=coeffp*ees0pij
9348       coeffmees0mij=coeffm*ees0mij
9349       coeffpees0pkl=coeffp*ees0pkl
9350       coeffmees0mkl=coeffm*ees0mkl
9351       do ll=1,3
9352 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9353         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
9354         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
9355         coeffmees0mkl*gacontm_hb1(ll,jj,i))
9356         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
9357         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
9358         coeffmees0mkl*gacontm_hb2(ll,jj,i))
9359 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9360         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
9361         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
9362         coeffmees0mij*gacontm_hb1(ll,kk,k))
9363         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
9364         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
9365         coeffmees0mij*gacontm_hb2(ll,kk,k))
9366         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
9367            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
9368            coeffmees0mkl*gacontm_hb3(ll,jj,i))
9369         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9370         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9371         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
9372            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
9373            coeffmees0mij*gacontm_hb3(ll,kk,k))
9374         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9375         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9376 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9377       enddo
9378 !      write (iout,*)
9379 !grad      do m=i+1,j-1
9380 !grad        do ll=1,3
9381 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
9382 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9383 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9384 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9385 !grad        enddo
9386 !grad      enddo
9387 !grad      do m=k+1,l-1
9388 !grad        do ll=1,3
9389 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
9390 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
9391 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9392 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9393 !grad        enddo
9394 !grad      enddo
9395 !      write (iout,*) "ehbcorr",ekont*ees
9396       ehbcorr=ekont*ees
9397       if (shield_mode.gt.0) then
9398        j=ees0plist(jj,i)
9399        l=ees0plist(kk,k)
9400 !C        print *,i,j,fac_shield(i),fac_shield(j),
9401 !C     &fac_shield(k),fac_shield(l)
9402         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
9403            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9404           do ilist=1,ishield_list(i)
9405            iresshield=shield_list(ilist,i)
9406            do m=1,3
9407            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9408            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
9409                    rlocshield  &
9410             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9411             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
9412             +rlocshield
9413            enddo
9414           enddo
9415           do ilist=1,ishield_list(j)
9416            iresshield=shield_list(ilist,j)
9417            do m=1,3
9418            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9419            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
9420                    rlocshield &
9421             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9422            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
9423             +rlocshield
9424            enddo
9425           enddo
9426
9427           do ilist=1,ishield_list(k)
9428            iresshield=shield_list(ilist,k)
9429            do m=1,3
9430            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9431            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
9432                    rlocshield &
9433             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9434            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
9435             +rlocshield
9436            enddo
9437           enddo
9438           do ilist=1,ishield_list(l)
9439            iresshield=shield_list(ilist,l)
9440            do m=1,3
9441            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9442            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
9443                    rlocshield &
9444             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9445            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
9446             +rlocshield
9447            enddo
9448           enddo
9449           do m=1,3
9450             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
9451                    grad_shield(m,i)*ehbcorr/fac_shield(i)
9452             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
9453                    grad_shield(m,j)*ehbcorr/fac_shield(j)
9454             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
9455                    grad_shield(m,i)*ehbcorr/fac_shield(i)
9456             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
9457                    grad_shield(m,j)*ehbcorr/fac_shield(j)
9458
9459             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
9460                    grad_shield(m,k)*ehbcorr/fac_shield(k)
9461             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
9462                    grad_shield(m,l)*ehbcorr/fac_shield(l)
9463             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
9464                    grad_shield(m,k)*ehbcorr/fac_shield(k)
9465             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
9466                    grad_shield(m,l)*ehbcorr/fac_shield(l)
9467
9468            enddo
9469       endif
9470       endif
9471       return
9472       end function ehbcorr
9473 #ifdef MOMENT
9474 !-----------------------------------------------------------------------------
9475       subroutine dipole(i,j,jj)
9476 !      implicit real*8 (a-h,o-z)
9477 !      include 'DIMENSIONS'
9478 !      include 'COMMON.IOUNITS'
9479 !      include 'COMMON.CHAIN'
9480 !      include 'COMMON.FFIELD'
9481 !      include 'COMMON.DERIV'
9482 !      include 'COMMON.INTERACT'
9483 !      include 'COMMON.CONTACTS'
9484 !      include 'COMMON.TORSION'
9485 !      include 'COMMON.VAR'
9486 !      include 'COMMON.GEO'
9487       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
9488       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
9489       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
9490
9491       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
9492       allocate(dipderx(3,5,4,maxconts,nres))
9493 !
9494
9495       iti1 = itortyp(itype(i+1,1))
9496       if (j.lt.nres-1) then
9497         itj1 = itype2loc(itype(j+1,1))
9498       else
9499         itj1=nloctyp
9500       endif
9501       do iii=1,2
9502         dipi(iii,1)=Ub2(iii,i)
9503         dipderi(iii)=Ub2der(iii,i)
9504         dipi(iii,2)=b1(iii,iti1)
9505         dipj(iii,1)=Ub2(iii,j)
9506         dipderj(iii)=Ub2der(iii,j)
9507         dipj(iii,2)=b1(iii,itj1)
9508       enddo
9509       kkk=0
9510       do iii=1,2
9511         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9512         do jjj=1,2
9513           kkk=kkk+1
9514           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9515         enddo
9516       enddo
9517       do kkk=1,5
9518         do lll=1,3
9519           mmm=0
9520           do iii=1,2
9521             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
9522               auxvec(1))
9523             do jjj=1,2
9524               mmm=mmm+1
9525               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9526             enddo
9527           enddo
9528         enddo
9529       enddo
9530       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9531       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9532       do iii=1,2
9533         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9534       enddo
9535       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9536       do iii=1,2
9537         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9538       enddo
9539       return
9540       end subroutine dipole
9541 #endif
9542 !-----------------------------------------------------------------------------
9543       subroutine calc_eello(i,j,k,l,jj,kk)
9544 !
9545 ! This subroutine computes matrices and vectors needed to calculate
9546 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
9547 !
9548       use comm_kut
9549 !      implicit real*8 (a-h,o-z)
9550 !      include 'DIMENSIONS'
9551 !      include 'COMMON.IOUNITS'
9552 !      include 'COMMON.CHAIN'
9553 !      include 'COMMON.DERIV'
9554 !      include 'COMMON.INTERACT'
9555 !      include 'COMMON.CONTACTS'
9556 !      include 'COMMON.TORSION'
9557 !      include 'COMMON.VAR'
9558 !      include 'COMMON.GEO'
9559 !      include 'COMMON.FFIELD'
9560       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
9561       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
9562       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
9563               itj1
9564 !el      logical :: lprn
9565 !el      common /kutas/ lprn
9566 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9567 !d     & ' jj=',jj,' kk=',kk
9568 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9569 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9570 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9571       do iii=1,2
9572         do jjj=1,2
9573           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9574           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9575         enddo
9576       enddo
9577       call transpose2(aa1(1,1),aa1t(1,1))
9578       call transpose2(aa2(1,1),aa2t(1,1))
9579       do kkk=1,5
9580         do lll=1,3
9581           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
9582             aa1tder(1,1,lll,kkk))
9583           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
9584             aa2tder(1,1,lll,kkk))
9585         enddo
9586       enddo
9587       if (l.eq.j+1) then
9588 ! parallel orientation of the two CA-CA-CA frames.
9589         if (i.gt.1) then
9590           iti=itortyp(itype(i,1))
9591         else
9592           iti=ntortyp+1
9593         endif
9594         itk1=itortyp(itype(k+1,1))
9595         itj=itortyp(itype(j,1))
9596         if (l.lt.nres-1) then
9597           itl1=itortyp(itype(l+1,1))
9598         else
9599           itl1=ntortyp+1
9600         endif
9601 ! A1 kernel(j+1) A2T
9602 !d        do iii=1,2
9603 !d          write (iout,'(3f10.5,5x,3f10.5)')
9604 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9605 !d        enddo
9606         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9607          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
9608          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9609 ! Following matrices are needed only for 6-th order cumulants
9610         IF (wcorr6.gt.0.0d0) THEN
9611         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9612          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
9613          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9614         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9615          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
9616          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9617          ADtEAderx(1,1,1,1,1,1))
9618         lprn=.false.
9619         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9620          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
9621          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9622          ADtEA1derx(1,1,1,1,1,1))
9623         ENDIF
9624 ! End 6-th order cumulants
9625 !d        lprn=.false.
9626 !d        if (lprn) then
9627 !d        write (2,*) 'In calc_eello6'
9628 !d        do iii=1,2
9629 !d          write (2,*) 'iii=',iii
9630 !d          do kkk=1,5
9631 !d            write (2,*) 'kkk=',kkk
9632 !d            do jjj=1,2
9633 !d              write (2,'(3(2f10.5),5x)')
9634 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9635 !d            enddo
9636 !d          enddo
9637 !d        enddo
9638 !d        endif
9639         call transpose2(EUgder(1,1,k),auxmat(1,1))
9640         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9641         call transpose2(EUg(1,1,k),auxmat(1,1))
9642         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9643         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9644         do iii=1,2
9645           do kkk=1,5
9646             do lll=1,3
9647               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9648                 EAEAderx(1,1,lll,kkk,iii,1))
9649             enddo
9650           enddo
9651         enddo
9652 ! A1T kernel(i+1) A2
9653         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9654          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
9655          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9656 ! Following matrices are needed only for 6-th order cumulants
9657         IF (wcorr6.gt.0.0d0) THEN
9658         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9659          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
9660          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9661         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9662          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
9663          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9664          ADtEAderx(1,1,1,1,1,2))
9665         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9666          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
9667          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9668          ADtEA1derx(1,1,1,1,1,2))
9669         ENDIF
9670 ! End 6-th order cumulants
9671         call transpose2(EUgder(1,1,l),auxmat(1,1))
9672         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9673         call transpose2(EUg(1,1,l),auxmat(1,1))
9674         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9675         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9676         do iii=1,2
9677           do kkk=1,5
9678             do lll=1,3
9679               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9680                 EAEAderx(1,1,lll,kkk,iii,2))
9681             enddo
9682           enddo
9683         enddo
9684 ! AEAb1 and AEAb2
9685 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9686 ! They are needed only when the fifth- or the sixth-order cumulants are
9687 ! indluded.
9688         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9689         call transpose2(AEA(1,1,1),auxmat(1,1))
9690         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9691         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9692         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9693         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9694         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9695         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9696         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9697         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9698         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9699         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9700         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9701         call transpose2(AEA(1,1,2),auxmat(1,1))
9702         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
9703         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9704         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9705         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9706         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
9707         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9708         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
9709         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
9710         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9711         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9712         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9713 ! Calculate the Cartesian derivatives of the vectors.
9714         do iii=1,2
9715           do kkk=1,5
9716             do lll=1,3
9717               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9718               call matvec2(auxmat(1,1),b1(1,iti),&
9719                 AEAb1derx(1,lll,kkk,iii,1,1))
9720               call matvec2(auxmat(1,1),Ub2(1,i),&
9721                 AEAb2derx(1,lll,kkk,iii,1,1))
9722               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9723                 AEAb1derx(1,lll,kkk,iii,2,1))
9724               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9725                 AEAb2derx(1,lll,kkk,iii,2,1))
9726               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9727               call matvec2(auxmat(1,1),b1(1,itj),&
9728                 AEAb1derx(1,lll,kkk,iii,1,2))
9729               call matvec2(auxmat(1,1),Ub2(1,j),&
9730                 AEAb2derx(1,lll,kkk,iii,1,2))
9731               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9732                 AEAb1derx(1,lll,kkk,iii,2,2))
9733               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
9734                 AEAb2derx(1,lll,kkk,iii,2,2))
9735             enddo
9736           enddo
9737         enddo
9738         ENDIF
9739 ! End vectors
9740       else
9741 ! Antiparallel orientation of the two CA-CA-CA frames.
9742         if (i.gt.1) then
9743           iti=itortyp(itype(i,1))
9744         else
9745           iti=ntortyp+1
9746         endif
9747         itk1=itortyp(itype(k+1,1))
9748         itl=itortyp(itype(l,1))
9749         itj=itortyp(itype(j,1))
9750         if (j.lt.nres-1) then
9751           itj1=itortyp(itype(j+1,1))
9752         else
9753           itj1=ntortyp+1
9754         endif
9755 ! A2 kernel(j-1)T A1T
9756         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9757          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
9758          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9759 ! Following matrices are needed only for 6-th order cumulants
9760         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9761            j.eq.i+4 .and. l.eq.i+3)) THEN
9762         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9763          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
9764          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9765         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9766          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
9767          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9768          ADtEAderx(1,1,1,1,1,1))
9769         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9770          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
9771          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9772          ADtEA1derx(1,1,1,1,1,1))
9773         ENDIF
9774 ! End 6-th order cumulants
9775         call transpose2(EUgder(1,1,k),auxmat(1,1))
9776         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9777         call transpose2(EUg(1,1,k),auxmat(1,1))
9778         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9779         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9780         do iii=1,2
9781           do kkk=1,5
9782             do lll=1,3
9783               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9784                 EAEAderx(1,1,lll,kkk,iii,1))
9785             enddo
9786           enddo
9787         enddo
9788 ! A2T kernel(i+1)T A1
9789         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9790          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
9791          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9792 ! Following matrices are needed only for 6-th order cumulants
9793         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9794            j.eq.i+4 .and. l.eq.i+3)) THEN
9795         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9796          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
9797          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9798         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9799          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
9800          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9801          ADtEAderx(1,1,1,1,1,2))
9802         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9803          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
9804          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9805          ADtEA1derx(1,1,1,1,1,2))
9806         ENDIF
9807 ! End 6-th order cumulants
9808         call transpose2(EUgder(1,1,j),auxmat(1,1))
9809         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9810         call transpose2(EUg(1,1,j),auxmat(1,1))
9811         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9812         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9813         do iii=1,2
9814           do kkk=1,5
9815             do lll=1,3
9816               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9817                 EAEAderx(1,1,lll,kkk,iii,2))
9818             enddo
9819           enddo
9820         enddo
9821 ! AEAb1 and AEAb2
9822 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9823 ! They are needed only when the fifth- or the sixth-order cumulants are
9824 ! indluded.
9825         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
9826           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9827         call transpose2(AEA(1,1,1),auxmat(1,1))
9828         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9829         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9830         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9831         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9832         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9833         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9834         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9835         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9836         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9837         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9838         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9839         call transpose2(AEA(1,1,2),auxmat(1,1))
9840         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
9841         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9842         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9843         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9844         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
9845         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9846         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
9847         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
9848         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9849         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9850         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9851 ! Calculate the Cartesian derivatives of the vectors.
9852         do iii=1,2
9853           do kkk=1,5
9854             do lll=1,3
9855               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9856               call matvec2(auxmat(1,1),b1(1,iti),&
9857                 AEAb1derx(1,lll,kkk,iii,1,1))
9858               call matvec2(auxmat(1,1),Ub2(1,i),&
9859                 AEAb2derx(1,lll,kkk,iii,1,1))
9860               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9861                 AEAb1derx(1,lll,kkk,iii,2,1))
9862               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9863                 AEAb2derx(1,lll,kkk,iii,2,1))
9864               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9865               call matvec2(auxmat(1,1),b1(1,itl),&
9866                 AEAb1derx(1,lll,kkk,iii,1,2))
9867               call matvec2(auxmat(1,1),Ub2(1,l),&
9868                 AEAb2derx(1,lll,kkk,iii,1,2))
9869               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
9870                 AEAb1derx(1,lll,kkk,iii,2,2))
9871               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
9872                 AEAb2derx(1,lll,kkk,iii,2,2))
9873             enddo
9874           enddo
9875         enddo
9876         ENDIF
9877 ! End vectors
9878       endif
9879       return
9880       end subroutine calc_eello
9881 !-----------------------------------------------------------------------------
9882       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
9883       use comm_kut
9884       implicit none
9885       integer :: nderg
9886       logical :: transp
9887       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
9888       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
9889       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
9890       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
9891       integer :: iii,kkk,lll
9892       integer :: jjj,mmm
9893 !el      logical :: lprn
9894 !el      common /kutas/ lprn
9895       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9896       do iii=1,nderg
9897         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
9898           AKAderg(1,1,iii))
9899       enddo
9900 !d      if (lprn) write (2,*) 'In kernel'
9901       do kkk=1,5
9902 !d        if (lprn) write (2,*) 'kkk=',kkk
9903         do lll=1,3
9904           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
9905             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9906 !d          if (lprn) then
9907 !d            write (2,*) 'lll=',lll
9908 !d            write (2,*) 'iii=1'
9909 !d            do jjj=1,2
9910 !d              write (2,'(3(2f10.5),5x)')
9911 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9912 !d            enddo
9913 !d          endif
9914           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
9915             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9916 !d          if (lprn) then
9917 !d            write (2,*) 'lll=',lll
9918 !d            write (2,*) 'iii=2'
9919 !d            do jjj=1,2
9920 !d              write (2,'(3(2f10.5),5x)')
9921 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9922 !d            enddo
9923 !d          endif
9924         enddo
9925       enddo
9926       return
9927       end subroutine kernel
9928 !-----------------------------------------------------------------------------
9929       real(kind=8) function eello4(i,j,k,l,jj,kk)
9930 !      implicit real*8 (a-h,o-z)
9931 !      include 'DIMENSIONS'
9932 !      include 'COMMON.IOUNITS'
9933 !      include 'COMMON.CHAIN'
9934 !      include 'COMMON.DERIV'
9935 !      include 'COMMON.INTERACT'
9936 !      include 'COMMON.CONTACTS'
9937 !      include 'COMMON.TORSION'
9938 !      include 'COMMON.VAR'
9939 !      include 'COMMON.GEO'
9940       real(kind=8),dimension(2,2) :: pizda
9941       real(kind=8),dimension(3) :: ggg1,ggg2
9942       real(kind=8) ::  eel4,glongij,glongkl
9943       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9944 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9945 !d        eello4=0.0d0
9946 !d        return
9947 !d      endif
9948 !d      print *,'eello4:',i,j,k,l,jj,kk
9949 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
9950 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
9951 !old      eij=facont_hb(jj,i)
9952 !old      ekl=facont_hb(kk,k)
9953 !old      ekont=eij*ekl
9954       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9955 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9956       gcorr_loc(k-1)=gcorr_loc(k-1) &
9957          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9958       if (l.eq.j+1) then
9959         gcorr_loc(l-1)=gcorr_loc(l-1) &
9960            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9961       else
9962         gcorr_loc(j-1)=gcorr_loc(j-1) &
9963            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9964       endif
9965       do iii=1,2
9966         do kkk=1,5
9967           do lll=1,3
9968             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
9969                               -EAEAderx(2,2,lll,kkk,iii,1)
9970 !d            derx(lll,kkk,iii)=0.0d0
9971           enddo
9972         enddo
9973       enddo
9974 !d      gcorr_loc(l-1)=0.0d0
9975 !d      gcorr_loc(j-1)=0.0d0
9976 !d      gcorr_loc(k-1)=0.0d0
9977 !d      eel4=1.0d0
9978 !d      write (iout,*)'Contacts have occurred for peptide groups',
9979 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9980 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9981       if (j.lt.nres-1) then
9982         j1=j+1
9983         j2=j-1
9984       else
9985         j1=j-1
9986         j2=j-2
9987       endif
9988       if (l.lt.nres-1) then
9989         l1=l+1
9990         l2=l-1
9991       else
9992         l1=l-1
9993         l2=l-2
9994       endif
9995       do ll=1,3
9996 !grad        ggg1(ll)=eel4*g_contij(ll,1)
9997 !grad        ggg2(ll)=eel4*g_contij(ll,2)
9998         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9999         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
10000 !grad        ghalf=0.5d0*ggg1(ll)
10001         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
10002         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
10003         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
10004         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
10005         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
10006         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
10007 !grad        ghalf=0.5d0*ggg2(ll)
10008         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
10009         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10010         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10011         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10012         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10013         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10014       enddo
10015 !grad      do m=i+1,j-1
10016 !grad        do ll=1,3
10017 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10018 !grad        enddo
10019 !grad      enddo
10020 !grad      do m=k+1,l-1
10021 !grad        do ll=1,3
10022 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10023 !grad        enddo
10024 !grad      enddo
10025 !grad      do m=i+2,j2
10026 !grad        do ll=1,3
10027 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10028 !grad        enddo
10029 !grad      enddo
10030 !grad      do m=k+2,l2
10031 !grad        do ll=1,3
10032 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10033 !grad        enddo
10034 !grad      enddo
10035 !d      do iii=1,nres-3
10036 !d        write (2,*) iii,gcorr_loc(iii)
10037 !d      enddo
10038       eello4=ekont*eel4
10039 !d      write (2,*) 'ekont',ekont
10040 !d      write (iout,*) 'eello4',ekont*eel4
10041       return
10042       end function eello4
10043 !-----------------------------------------------------------------------------
10044       real(kind=8) function eello5(i,j,k,l,jj,kk)
10045 !      implicit real*8 (a-h,o-z)
10046 !      include 'DIMENSIONS'
10047 !      include 'COMMON.IOUNITS'
10048 !      include 'COMMON.CHAIN'
10049 !      include 'COMMON.DERIV'
10050 !      include 'COMMON.INTERACT'
10051 !      include 'COMMON.CONTACTS'
10052 !      include 'COMMON.TORSION'
10053 !      include 'COMMON.VAR'
10054 !      include 'COMMON.GEO'
10055       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10056       real(kind=8),dimension(2) :: vv
10057       real(kind=8),dimension(3) :: ggg1,ggg2
10058       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
10059       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
10060       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
10061 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10062 !                                                                              C
10063 !                            Parallel chains                                   C
10064 !                                                                              C
10065 !          o             o                   o             o                   C
10066 !         /l\           / \             \   / \           / \   /              C
10067 !        /   \         /   \             \ /   \         /   \ /               C
10068 !       j| o |l1       | o |                o| o |         | o |o                C
10069 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10070 !      \i/   \         /   \ /             /   \         /   \                 C
10071 !       o    k1             o                                                  C
10072 !         (I)          (II)                (III)          (IV)                 C
10073 !                                                                              C
10074 !      eello5_1        eello5_2            eello5_3       eello5_4             C
10075 !                                                                              C
10076 !                            Antiparallel chains                               C
10077 !                                                                              C
10078 !          o             o                   o             o                   C
10079 !         /j\           / \             \   / \           / \   /              C
10080 !        /   \         /   \             \ /   \         /   \ /               C
10081 !      j1| o |l        | o |                o| o |         | o |o                C
10082 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10083 !      \i/   \         /   \ /             /   \         /   \                 C
10084 !       o     k1            o                                                  C
10085 !         (I)          (II)                (III)          (IV)                 C
10086 !                                                                              C
10087 !      eello5_1        eello5_2            eello5_3       eello5_4             C
10088 !                                                                              C
10089 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
10090 !                                                                              C
10091 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10092 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10093 !d        eello5=0.0d0
10094 !d        return
10095 !d      endif
10096 !d      write (iout,*)
10097 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10098 !d     &   ' and',k,l
10099       itk=itortyp(itype(k,1))
10100       itl=itortyp(itype(l,1))
10101       itj=itortyp(itype(j,1))
10102       eello5_1=0.0d0
10103       eello5_2=0.0d0
10104       eello5_3=0.0d0
10105       eello5_4=0.0d0
10106 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10107 !d     &   eel5_3_num,eel5_4_num)
10108       do iii=1,2
10109         do kkk=1,5
10110           do lll=1,3
10111             derx(lll,kkk,iii)=0.0d0
10112           enddo
10113         enddo
10114       enddo
10115 !d      eij=facont_hb(jj,i)
10116 !d      ekl=facont_hb(kk,k)
10117 !d      ekont=eij*ekl
10118 !d      write (iout,*)'Contacts have occurred for peptide groups',
10119 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
10120 !d      goto 1111
10121 ! Contribution from the graph I.
10122 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10123 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10124       call transpose2(EUg(1,1,k),auxmat(1,1))
10125       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10126       vv(1)=pizda(1,1)-pizda(2,2)
10127       vv(2)=pizda(1,2)+pizda(2,1)
10128       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
10129        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10130 ! Explicit gradient in virtual-dihedral angles.
10131       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
10132        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
10133        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10134       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10135       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10136       vv(1)=pizda(1,1)-pizda(2,2)
10137       vv(2)=pizda(1,2)+pizda(2,1)
10138       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10139        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
10140        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10141       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10142       vv(1)=pizda(1,1)-pizda(2,2)
10143       vv(2)=pizda(1,2)+pizda(2,1)
10144       if (l.eq.j+1) then
10145         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10146          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
10147          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10148       else
10149         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10150          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
10151          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10152       endif
10153 ! Cartesian gradient
10154       do iii=1,2
10155         do kkk=1,5
10156           do lll=1,3
10157             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
10158               pizda(1,1))
10159             vv(1)=pizda(1,1)-pizda(2,2)
10160             vv(2)=pizda(1,2)+pizda(2,1)
10161             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
10162              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
10163              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10164           enddo
10165         enddo
10166       enddo
10167 !      goto 1112
10168 !1111  continue
10169 ! Contribution from graph II
10170       call transpose2(EE(1,1,itk),auxmat(1,1))
10171       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10172       vv(1)=pizda(1,1)+pizda(2,2)
10173       vv(2)=pizda(2,1)-pizda(1,2)
10174       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
10175        -0.5d0*scalar2(vv(1),Ctobr(1,k))
10176 ! Explicit gradient in virtual-dihedral angles.
10177       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10178        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10179       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10180       vv(1)=pizda(1,1)+pizda(2,2)
10181       vv(2)=pizda(2,1)-pizda(1,2)
10182       if (l.eq.j+1) then
10183         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10184          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
10185          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10186       else
10187         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10188          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
10189          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10190       endif
10191 ! Cartesian gradient
10192       do iii=1,2
10193         do kkk=1,5
10194           do lll=1,3
10195             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
10196               pizda(1,1))
10197             vv(1)=pizda(1,1)+pizda(2,2)
10198             vv(2)=pizda(2,1)-pizda(1,2)
10199             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
10200              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
10201              -0.5d0*scalar2(vv(1),Ctobr(1,k))
10202           enddo
10203         enddo
10204       enddo
10205 !d      goto 1112
10206 !d1111  continue
10207       if (l.eq.j+1) then
10208 !d        goto 1110
10209 ! Parallel orientation
10210 ! Contribution from graph III
10211         call transpose2(EUg(1,1,l),auxmat(1,1))
10212         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10213         vv(1)=pizda(1,1)-pizda(2,2)
10214         vv(2)=pizda(1,2)+pizda(2,1)
10215         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
10216          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10217 ! Explicit gradient in virtual-dihedral angles.
10218         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10219          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
10220          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10221         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10222         vv(1)=pizda(1,1)-pizda(2,2)
10223         vv(2)=pizda(1,2)+pizda(2,1)
10224         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10225          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
10226          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10227         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10228         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10229         vv(1)=pizda(1,1)-pizda(2,2)
10230         vv(2)=pizda(1,2)+pizda(2,1)
10231         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10232          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
10233          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10234 ! Cartesian gradient
10235         do iii=1,2
10236           do kkk=1,5
10237             do lll=1,3
10238               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
10239                 pizda(1,1))
10240               vv(1)=pizda(1,1)-pizda(2,2)
10241               vv(2)=pizda(1,2)+pizda(2,1)
10242               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
10243                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
10244                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10245             enddo
10246           enddo
10247         enddo
10248 !d        goto 1112
10249 ! Contribution from graph IV
10250 !d1110    continue
10251         call transpose2(EE(1,1,itl),auxmat(1,1))
10252         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10253         vv(1)=pizda(1,1)+pizda(2,2)
10254         vv(2)=pizda(2,1)-pizda(1,2)
10255         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
10256          -0.5d0*scalar2(vv(1),Ctobr(1,l))
10257 ! Explicit gradient in virtual-dihedral angles.
10258         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10259          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10260         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10261         vv(1)=pizda(1,1)+pizda(2,2)
10262         vv(2)=pizda(2,1)-pizda(1,2)
10263         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10264          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
10265          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10266 ! Cartesian gradient
10267         do iii=1,2
10268           do kkk=1,5
10269             do lll=1,3
10270               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
10271                 pizda(1,1))
10272               vv(1)=pizda(1,1)+pizda(2,2)
10273               vv(2)=pizda(2,1)-pizda(1,2)
10274               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
10275                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
10276                -0.5d0*scalar2(vv(1),Ctobr(1,l))
10277             enddo
10278           enddo
10279         enddo
10280       else
10281 ! Antiparallel orientation
10282 ! Contribution from graph III
10283 !        goto 1110
10284         call transpose2(EUg(1,1,j),auxmat(1,1))
10285         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10286         vv(1)=pizda(1,1)-pizda(2,2)
10287         vv(2)=pizda(1,2)+pizda(2,1)
10288         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
10289          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10290 ! Explicit gradient in virtual-dihedral angles.
10291         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10292          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
10293          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10294         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10295         vv(1)=pizda(1,1)-pizda(2,2)
10296         vv(2)=pizda(1,2)+pizda(2,1)
10297         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10298          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
10299          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10300         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10301         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10302         vv(1)=pizda(1,1)-pizda(2,2)
10303         vv(2)=pizda(1,2)+pizda(2,1)
10304         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10305          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
10306          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10307 ! Cartesian gradient
10308         do iii=1,2
10309           do kkk=1,5
10310             do lll=1,3
10311               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
10312                 pizda(1,1))
10313               vv(1)=pizda(1,1)-pizda(2,2)
10314               vv(2)=pizda(1,2)+pizda(2,1)
10315               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
10316                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
10317                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10318             enddo
10319           enddo
10320         enddo
10321 !d        goto 1112
10322 ! Contribution from graph IV
10323 1110    continue
10324         call transpose2(EE(1,1,itj),auxmat(1,1))
10325         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10326         vv(1)=pizda(1,1)+pizda(2,2)
10327         vv(2)=pizda(2,1)-pizda(1,2)
10328         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
10329          -0.5d0*scalar2(vv(1),Ctobr(1,j))
10330 ! Explicit gradient in virtual-dihedral angles.
10331         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10332          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10333         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10334         vv(1)=pizda(1,1)+pizda(2,2)
10335         vv(2)=pizda(2,1)-pizda(1,2)
10336         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10337          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
10338          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10339 ! Cartesian gradient
10340         do iii=1,2
10341           do kkk=1,5
10342             do lll=1,3
10343               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
10344                 pizda(1,1))
10345               vv(1)=pizda(1,1)+pizda(2,2)
10346               vv(2)=pizda(2,1)-pizda(1,2)
10347               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
10348                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
10349                -0.5d0*scalar2(vv(1),Ctobr(1,j))
10350             enddo
10351           enddo
10352         enddo
10353       endif
10354 1112  continue
10355       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10356 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10357 !d        write (2,*) 'ijkl',i,j,k,l
10358 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10359 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10360 !d      endif
10361 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10362 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10363 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10364 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10365       if (j.lt.nres-1) then
10366         j1=j+1
10367         j2=j-1
10368       else
10369         j1=j-1
10370         j2=j-2
10371       endif
10372       if (l.lt.nres-1) then
10373         l1=l+1
10374         l2=l-1
10375       else
10376         l1=l-1
10377         l2=l-2
10378       endif
10379 !d      eij=1.0d0
10380 !d      ekl=1.0d0
10381 !d      ekont=1.0d0
10382 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10383 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
10384 !        summed up outside the subrouine as for the other subroutines
10385 !        handling long-range interactions. The old code is commented out
10386 !        with "cgrad" to keep track of changes.
10387       do ll=1,3
10388 !grad        ggg1(ll)=eel5*g_contij(ll,1)
10389 !grad        ggg2(ll)=eel5*g_contij(ll,2)
10390         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10391         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10392 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10393 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10394 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10395 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10396 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10397 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10398 !     &   gradcorr5ij,
10399 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10400 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10401 !grad        ghalf=0.5d0*ggg1(ll)
10402 !d        ghalf=0.0d0
10403         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10404         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10405         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10406         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10407         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10408         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10409 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10410 !grad        ghalf=0.5d0*ggg2(ll)
10411         ghalf=0.0d0
10412         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
10413         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10414         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
10415         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10416         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10417         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10418       enddo
10419 !d      goto 1112
10420 !grad      do m=i+1,j-1
10421 !grad        do ll=1,3
10422 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10423 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10424 !grad        enddo
10425 !grad      enddo
10426 !grad      do m=k+1,l-1
10427 !grad        do ll=1,3
10428 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10429 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10430 !grad        enddo
10431 !grad      enddo
10432 !1112  continue
10433 !grad      do m=i+2,j2
10434 !grad        do ll=1,3
10435 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10436 !grad        enddo
10437 !grad      enddo
10438 !grad      do m=k+2,l2
10439 !grad        do ll=1,3
10440 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10441 !grad        enddo
10442 !grad      enddo
10443 !d      do iii=1,nres-3
10444 !d        write (2,*) iii,g_corr5_loc(iii)
10445 !d      enddo
10446       eello5=ekont*eel5
10447 !d      write (2,*) 'ekont',ekont
10448 !d      write (iout,*) 'eello5',ekont*eel5
10449       return
10450       end function eello5
10451 !-----------------------------------------------------------------------------
10452       real(kind=8) function eello6(i,j,k,l,jj,kk)
10453 !      implicit real*8 (a-h,o-z)
10454 !      include 'DIMENSIONS'
10455 !      include 'COMMON.IOUNITS'
10456 !      include 'COMMON.CHAIN'
10457 !      include 'COMMON.DERIV'
10458 !      include 'COMMON.INTERACT'
10459 !      include 'COMMON.CONTACTS'
10460 !      include 'COMMON.TORSION'
10461 !      include 'COMMON.VAR'
10462 !      include 'COMMON.GEO'
10463 !      include 'COMMON.FFIELD'
10464       real(kind=8),dimension(3) :: ggg1,ggg2
10465       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
10466                    eello6_6,eel6
10467       real(kind=8) :: gradcorr6ij,gradcorr6kl
10468       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
10469 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10470 !d        eello6=0.0d0
10471 !d        return
10472 !d      endif
10473 !d      write (iout,*)
10474 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10475 !d     &   ' and',k,l
10476       eello6_1=0.0d0
10477       eello6_2=0.0d0
10478       eello6_3=0.0d0
10479       eello6_4=0.0d0
10480       eello6_5=0.0d0
10481       eello6_6=0.0d0
10482 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10483 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10484       do iii=1,2
10485         do kkk=1,5
10486           do lll=1,3
10487             derx(lll,kkk,iii)=0.0d0
10488           enddo
10489         enddo
10490       enddo
10491 !d      eij=facont_hb(jj,i)
10492 !d      ekl=facont_hb(kk,k)
10493 !d      ekont=eij*ekl
10494 !d      eij=1.0d0
10495 !d      ekl=1.0d0
10496 !d      ekont=1.0d0
10497       if (l.eq.j+1) then
10498         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10499         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10500         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10501         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10502         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10503         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10504       else
10505         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10506         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10507         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10508         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10509         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10510           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10511         else
10512           eello6_5=0.0d0
10513         endif
10514         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10515       endif
10516 ! If turn contributions are considered, they will be handled separately.
10517       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10518 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10519 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10520 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10521 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10522 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10523 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10524 !d      goto 1112
10525       if (j.lt.nres-1) then
10526         j1=j+1
10527         j2=j-1
10528       else
10529         j1=j-1
10530         j2=j-2
10531       endif
10532       if (l.lt.nres-1) then
10533         l1=l+1
10534         l2=l-1
10535       else
10536         l1=l-1
10537         l2=l-2
10538       endif
10539       do ll=1,3
10540 !grad        ggg1(ll)=eel6*g_contij(ll,1)
10541 !grad        ggg2(ll)=eel6*g_contij(ll,2)
10542 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10543 !grad        ghalf=0.5d0*ggg1(ll)
10544 !d        ghalf=0.0d0
10545         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10546         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10547         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10548         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10549         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10550         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10551         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10552         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10553 !grad        ghalf=0.5d0*ggg2(ll)
10554 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10555 !d        ghalf=0.0d0
10556         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10557         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10558         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10559         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10560         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10561         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10562       enddo
10563 !d      goto 1112
10564 !grad      do m=i+1,j-1
10565 !grad        do ll=1,3
10566 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10567 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10568 !grad        enddo
10569 !grad      enddo
10570 !grad      do m=k+1,l-1
10571 !grad        do ll=1,3
10572 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10573 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10574 !grad        enddo
10575 !grad      enddo
10576 !grad1112  continue
10577 !grad      do m=i+2,j2
10578 !grad        do ll=1,3
10579 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10580 !grad        enddo
10581 !grad      enddo
10582 !grad      do m=k+2,l2
10583 !grad        do ll=1,3
10584 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10585 !grad        enddo
10586 !grad      enddo
10587 !d      do iii=1,nres-3
10588 !d        write (2,*) iii,g_corr6_loc(iii)
10589 !d      enddo
10590       eello6=ekont*eel6
10591 !d      write (2,*) 'ekont',ekont
10592 !d      write (iout,*) 'eello6',ekont*eel6
10593       return
10594       end function eello6
10595 !-----------------------------------------------------------------------------
10596       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
10597       use comm_kut
10598 !      implicit real*8 (a-h,o-z)
10599 !      include 'DIMENSIONS'
10600 !      include 'COMMON.IOUNITS'
10601 !      include 'COMMON.CHAIN'
10602 !      include 'COMMON.DERIV'
10603 !      include 'COMMON.INTERACT'
10604 !      include 'COMMON.CONTACTS'
10605 !      include 'COMMON.TORSION'
10606 !      include 'COMMON.VAR'
10607 !      include 'COMMON.GEO'
10608       real(kind=8),dimension(2) :: vv,vv1
10609       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
10610       logical :: swap
10611 !el      logical :: lprn
10612 !el      common /kutas/ lprn
10613       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
10614       real(kind=8) :: s1,s2,s3,s4,s5
10615 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10616 !                                                                              C
10617 !      Parallel       Antiparallel                                             C
10618 !                                                                              C
10619 !          o             o                                                     C
10620 !         /l\           /j\                                                    C
10621 !        /   \         /   \                                                   C
10622 !       /| o |         | o |\                                                  C
10623 !     \ j|/k\|  /   \  |/k\|l /                                                C
10624 !      \ /   \ /     \ /   \ /                                                 C
10625 !       o     o       o     o                                                  C
10626 !       i             i                                                        C
10627 !                                                                              C
10628 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10629       itk=itortyp(itype(k,1))
10630       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10631       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10632       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10633       call transpose2(EUgC(1,1,k),auxmat(1,1))
10634       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10635       vv1(1)=pizda1(1,1)-pizda1(2,2)
10636       vv1(2)=pizda1(1,2)+pizda1(2,1)
10637       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10638       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
10639       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
10640       s5=scalar2(vv(1),Dtobr2(1,i))
10641 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10642       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10643       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
10644        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
10645        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
10646        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
10647        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
10648        +scalar2(vv(1),Dtobr2der(1,i)))
10649       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10650       vv1(1)=pizda1(1,1)-pizda1(2,2)
10651       vv1(2)=pizda1(1,2)+pizda1(2,1)
10652       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
10653       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
10654       if (l.eq.j+1) then
10655         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
10656        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10657        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10658        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10659        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10660       else
10661         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
10662        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10663        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10664        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10665        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10666       endif
10667       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10668       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10669       vv1(1)=pizda1(1,1)-pizda1(2,2)
10670       vv1(2)=pizda1(1,2)+pizda1(2,1)
10671       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
10672        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
10673        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
10674        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10675       do iii=1,2
10676         if (swap) then
10677           ind=3-iii
10678         else
10679           ind=iii
10680         endif
10681         do kkk=1,5
10682           do lll=1,3
10683             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10684             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10685             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10686             call transpose2(EUgC(1,1,k),auxmat(1,1))
10687             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10688               pizda1(1,1))
10689             vv1(1)=pizda1(1,1)-pizda1(2,2)
10690             vv1(2)=pizda1(1,2)+pizda1(2,1)
10691             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10692             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
10693              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
10694             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
10695              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
10696             s5=scalar2(vv(1),Dtobr2(1,i))
10697             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10698           enddo
10699         enddo
10700       enddo
10701       return
10702       end function eello6_graph1
10703 !-----------------------------------------------------------------------------
10704       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
10705       use comm_kut
10706 !      implicit real*8 (a-h,o-z)
10707 !      include 'DIMENSIONS'
10708 !      include 'COMMON.IOUNITS'
10709 !      include 'COMMON.CHAIN'
10710 !      include 'COMMON.DERIV'
10711 !      include 'COMMON.INTERACT'
10712 !      include 'COMMON.CONTACTS'
10713 !      include 'COMMON.TORSION'
10714 !      include 'COMMON.VAR'
10715 !      include 'COMMON.GEO'
10716       logical :: swap
10717       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
10718       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10719 !el      logical :: lprn
10720 !el      common /kutas/ lprn
10721       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
10722       real(kind=8) :: s2,s3,s4
10723 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10724 !                                                                              C
10725 !      Parallel       Antiparallel                                             C
10726 !                                                                              C
10727 !          o             o                                                     C
10728 !     \   /l\           /j\   /                                                C
10729 !      \ /   \         /   \ /                                                 C
10730 !       o| o |         | o |o                                                  C
10731 !     \ j|/k\|      \  |/k\|l                                                  C
10732 !      \ /   \       \ /   \                                                   C
10733 !       o             o                                                        C
10734 !       i             i                                                        C
10735 !                                                                              C
10736 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10737 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10738 ! AL 7/4/01 s1 would occur in the sixth-order moment,
10739 !           but not in a cluster cumulant
10740 #ifdef MOMENT
10741       s1=dip(1,jj,i)*dip(1,kk,k)
10742 #endif
10743       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10744       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10745       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10746       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10747       call transpose2(EUg(1,1,k),auxmat(1,1))
10748       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10749       vv(1)=pizda(1,1)-pizda(2,2)
10750       vv(2)=pizda(1,2)+pizda(2,1)
10751       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10752 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10753 #ifdef MOMENT
10754       eello6_graph2=-(s1+s2+s3+s4)
10755 #else
10756       eello6_graph2=-(s2+s3+s4)
10757 #endif
10758 !      eello6_graph2=-s3
10759 ! Derivatives in gamma(i-1)
10760       if (i.gt.1) then
10761 #ifdef MOMENT
10762         s1=dipderg(1,jj,i)*dip(1,kk,k)
10763 #endif
10764         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10765         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10766         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10767         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10768 #ifdef MOMENT
10769         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10770 #else
10771         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10772 #endif
10773 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10774       endif
10775 ! Derivatives in gamma(k-1)
10776 #ifdef MOMENT
10777       s1=dip(1,jj,i)*dipderg(1,kk,k)
10778 #endif
10779       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10780       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10781       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10782       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10783       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10784       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10785       vv(1)=pizda(1,1)-pizda(2,2)
10786       vv(2)=pizda(1,2)+pizda(2,1)
10787       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10788 #ifdef MOMENT
10789       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10790 #else
10791       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10792 #endif
10793 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10794 ! Derivatives in gamma(j-1) or gamma(l-1)
10795       if (j.gt.1) then
10796 #ifdef MOMENT
10797         s1=dipderg(3,jj,i)*dip(1,kk,k)
10798 #endif
10799         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10800         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10801         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10802         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10803         vv(1)=pizda(1,1)-pizda(2,2)
10804         vv(2)=pizda(1,2)+pizda(2,1)
10805         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10806 #ifdef MOMENT
10807         if (swap) then
10808           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10809         else
10810           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10811         endif
10812 #endif
10813         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10814 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10815       endif
10816 ! Derivatives in gamma(l-1) or gamma(j-1)
10817       if (l.gt.1) then
10818 #ifdef MOMENT
10819         s1=dip(1,jj,i)*dipderg(3,kk,k)
10820 #endif
10821         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10822         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10823         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10824         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10825         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10826         vv(1)=pizda(1,1)-pizda(2,2)
10827         vv(2)=pizda(1,2)+pizda(2,1)
10828         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10829 #ifdef MOMENT
10830         if (swap) then
10831           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10832         else
10833           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10834         endif
10835 #endif
10836         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10837 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10838       endif
10839 ! Cartesian derivatives.
10840       if (lprn) then
10841         write (2,*) 'In eello6_graph2'
10842         do iii=1,2
10843           write (2,*) 'iii=',iii
10844           do kkk=1,5
10845             write (2,*) 'kkk=',kkk
10846             do jjj=1,2
10847               write (2,'(3(2f10.5),5x)') &
10848               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10849             enddo
10850           enddo
10851         enddo
10852       endif
10853       do iii=1,2
10854         do kkk=1,5
10855           do lll=1,3
10856 #ifdef MOMENT
10857             if (iii.eq.1) then
10858               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10859             else
10860               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10861             endif
10862 #endif
10863             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
10864               auxvec(1))
10865             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10866             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
10867               auxvec(1))
10868             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10869             call transpose2(EUg(1,1,k),auxmat(1,1))
10870             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
10871               pizda(1,1))
10872             vv(1)=pizda(1,1)-pizda(2,2)
10873             vv(2)=pizda(1,2)+pizda(2,1)
10874             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10875 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10876 #ifdef MOMENT
10877             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10878 #else
10879             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10880 #endif
10881             if (swap) then
10882               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10883             else
10884               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10885             endif
10886           enddo
10887         enddo
10888       enddo
10889       return
10890       end function eello6_graph2
10891 !-----------------------------------------------------------------------------
10892       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
10893 !      implicit real*8 (a-h,o-z)
10894 !      include 'DIMENSIONS'
10895 !      include 'COMMON.IOUNITS'
10896 !      include 'COMMON.CHAIN'
10897 !      include 'COMMON.DERIV'
10898 !      include 'COMMON.INTERACT'
10899 !      include 'COMMON.CONTACTS'
10900 !      include 'COMMON.TORSION'
10901 !      include 'COMMON.VAR'
10902 !      include 'COMMON.GEO'
10903       real(kind=8),dimension(2) :: vv,auxvec
10904       real(kind=8),dimension(2,2) :: pizda,auxmat
10905       logical :: swap
10906       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
10907       real(kind=8) :: s1,s2,s3,s4
10908 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10909 !                                                                              C
10910 !      Parallel       Antiparallel                                             C
10911 !                                                                              C
10912 !          o             o                                                     C
10913 !         /l\   /   \   /j\                                                    C
10914 !        /   \ /     \ /   \                                                   C
10915 !       /| o |o       o| o |\                                                  C
10916 !       j|/k\|  /      |/k\|l /                                                C
10917 !        /   \ /       /   \ /                                                 C
10918 !       /     o       /     o                                                  C
10919 !       i             i                                                        C
10920 !                                                                              C
10921 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10922 !
10923 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10924 !           energy moment and not to the cluster cumulant.
10925       iti=itortyp(itype(i,1))
10926       if (j.lt.nres-1) then
10927         itj1=itortyp(itype(j+1,1))
10928       else
10929         itj1=ntortyp+1
10930       endif
10931       itk=itortyp(itype(k,1))
10932       itk1=itortyp(itype(k+1,1))
10933       if (l.lt.nres-1) then
10934         itl1=itortyp(itype(l+1,1))
10935       else
10936         itl1=ntortyp+1
10937       endif
10938 #ifdef MOMENT
10939       s1=dip(4,jj,i)*dip(4,kk,k)
10940 #endif
10941       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
10942       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10943       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
10944       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10945       call transpose2(EE(1,1,itk),auxmat(1,1))
10946       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10947       vv(1)=pizda(1,1)+pizda(2,2)
10948       vv(2)=pizda(2,1)-pizda(1,2)
10949       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10950 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10951 !d     & "sum",-(s2+s3+s4)
10952 #ifdef MOMENT
10953       eello6_graph3=-(s1+s2+s3+s4)
10954 #else
10955       eello6_graph3=-(s2+s3+s4)
10956 #endif
10957 !      eello6_graph3=-s4
10958 ! Derivatives in gamma(k-1)
10959       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
10960       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10961       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10962       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10963 ! Derivatives in gamma(l-1)
10964       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
10965       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10966       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10967       vv(1)=pizda(1,1)+pizda(2,2)
10968       vv(2)=pizda(2,1)-pizda(1,2)
10969       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10970       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10971 ! Cartesian derivatives.
10972       do iii=1,2
10973         do kkk=1,5
10974           do lll=1,3
10975 #ifdef MOMENT
10976             if (iii.eq.1) then
10977               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10978             else
10979               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10980             endif
10981 #endif
10982             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
10983               auxvec(1))
10984             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10985             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
10986               auxvec(1))
10987             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10988             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
10989               pizda(1,1))
10990             vv(1)=pizda(1,1)+pizda(2,2)
10991             vv(2)=pizda(2,1)-pizda(1,2)
10992             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10993 #ifdef MOMENT
10994             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10995 #else
10996             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10997 #endif
10998             if (swap) then
10999               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11000             else
11001               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11002             endif
11003 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
11004           enddo
11005         enddo
11006       enddo
11007       return
11008       end function eello6_graph3
11009 !-----------------------------------------------------------------------------
11010       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11011 !      implicit real*8 (a-h,o-z)
11012 !      include 'DIMENSIONS'
11013 !      include 'COMMON.IOUNITS'
11014 !      include 'COMMON.CHAIN'
11015 !      include 'COMMON.DERIV'
11016 !      include 'COMMON.INTERACT'
11017 !      include 'COMMON.CONTACTS'
11018 !      include 'COMMON.TORSION'
11019 !      include 'COMMON.VAR'
11020 !      include 'COMMON.GEO'
11021 !      include 'COMMON.FFIELD'
11022       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
11023       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
11024       logical :: swap
11025       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
11026               iii,kkk,lll
11027       real(kind=8) :: s1,s2,s3,s4
11028 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11029 !                                                                              C
11030 !      Parallel       Antiparallel                                             C
11031 !                                                                              C
11032 !          o             o                                                     C
11033 !         /l\   /   \   /j\                                                    C
11034 !        /   \ /     \ /   \                                                   C
11035 !       /| o |o       o| o |\                                                  C
11036 !     \ j|/k\|      \  |/k\|l                                                  C
11037 !      \ /   \       \ /   \                                                   C
11038 !       o     \       o     \                                                  C
11039 !       i             i                                                        C
11040 !                                                                              C
11041 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11042 !
11043 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
11044 !           energy moment and not to the cluster cumulant.
11045 !d      write (2,*) 'eello_graph4: wturn6',wturn6
11046       iti=itortyp(itype(i,1))
11047       itj=itortyp(itype(j,1))
11048       if (j.lt.nres-1) then
11049         itj1=itortyp(itype(j+1,1))
11050       else
11051         itj1=ntortyp+1
11052       endif
11053       itk=itortyp(itype(k,1))
11054       if (k.lt.nres-1) then
11055         itk1=itortyp(itype(k+1,1))
11056       else
11057         itk1=ntortyp+1
11058       endif
11059       itl=itortyp(itype(l,1))
11060       if (l.lt.nres-1) then
11061         itl1=itortyp(itype(l+1,1))
11062       else
11063         itl1=ntortyp+1
11064       endif
11065 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11066 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11067 !d     & ' itl',itl,' itl1',itl1
11068 #ifdef MOMENT
11069       if (imat.eq.1) then
11070         s1=dip(3,jj,i)*dip(3,kk,k)
11071       else
11072         s1=dip(2,jj,j)*dip(2,kk,l)
11073       endif
11074 #endif
11075       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11076       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11077       if (j.eq.l+1) then
11078         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
11079         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
11080       else
11081         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
11082         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
11083       endif
11084       call transpose2(EUg(1,1,k),auxmat(1,1))
11085       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11086       vv(1)=pizda(1,1)-pizda(2,2)
11087       vv(2)=pizda(2,1)+pizda(1,2)
11088       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11089 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11090 #ifdef MOMENT
11091       eello6_graph4=-(s1+s2+s3+s4)
11092 #else
11093       eello6_graph4=-(s2+s3+s4)
11094 #endif
11095 ! Derivatives in gamma(i-1)
11096       if (i.gt.1) then
11097 #ifdef MOMENT
11098         if (imat.eq.1) then
11099           s1=dipderg(2,jj,i)*dip(3,kk,k)
11100         else
11101           s1=dipderg(4,jj,j)*dip(2,kk,l)
11102         endif
11103 #endif
11104         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11105         if (j.eq.l+1) then
11106           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
11107           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
11108         else
11109           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
11110           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
11111         endif
11112         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11113         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11114 !d          write (2,*) 'turn6 derivatives'
11115 #ifdef MOMENT
11116           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11117 #else
11118           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11119 #endif
11120         else
11121 #ifdef MOMENT
11122           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11123 #else
11124           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11125 #endif
11126         endif
11127       endif
11128 ! Derivatives in gamma(k-1)
11129 #ifdef MOMENT
11130       if (imat.eq.1) then
11131         s1=dip(3,jj,i)*dipderg(2,kk,k)
11132       else
11133         s1=dip(2,jj,j)*dipderg(4,kk,l)
11134       endif
11135 #endif
11136       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11137       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11138       if (j.eq.l+1) then
11139         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
11140         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
11141       else
11142         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
11143         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
11144       endif
11145       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11146       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11147       vv(1)=pizda(1,1)-pizda(2,2)
11148       vv(2)=pizda(2,1)+pizda(1,2)
11149       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11150       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11151 #ifdef MOMENT
11152         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11153 #else
11154         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11155 #endif
11156       else
11157 #ifdef MOMENT
11158         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11159 #else
11160         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11161 #endif
11162       endif
11163 ! Derivatives in gamma(j-1) or gamma(l-1)
11164       if (l.eq.j+1 .and. l.gt.1) then
11165         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11166         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11167         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11168         vv(1)=pizda(1,1)-pizda(2,2)
11169         vv(2)=pizda(2,1)+pizda(1,2)
11170         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11171         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11172       else if (j.gt.1) then
11173         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11174         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11175         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11176         vv(1)=pizda(1,1)-pizda(2,2)
11177         vv(2)=pizda(2,1)+pizda(1,2)
11178         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11179         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11180           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11181         else
11182           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11183         endif
11184       endif
11185 ! Cartesian derivatives.
11186       do iii=1,2
11187         do kkk=1,5
11188           do lll=1,3
11189 #ifdef MOMENT
11190             if (iii.eq.1) then
11191               if (imat.eq.1) then
11192                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11193               else
11194                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11195               endif
11196             else
11197               if (imat.eq.1) then
11198                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11199               else
11200                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11201               endif
11202             endif
11203 #endif
11204             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
11205               auxvec(1))
11206             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11207             if (j.eq.l+1) then
11208               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
11209                 b1(1,itj1),auxvec(1))
11210               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
11211             else
11212               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
11213                 b1(1,itl1),auxvec(1))
11214               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
11215             endif
11216             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
11217               pizda(1,1))
11218             vv(1)=pizda(1,1)-pizda(2,2)
11219             vv(2)=pizda(2,1)+pizda(1,2)
11220             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11221             if (swap) then
11222               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11223 #ifdef MOMENT
11224                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
11225                    -(s1+s2+s4)
11226 #else
11227                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
11228                    -(s2+s4)
11229 #endif
11230                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11231               else
11232 #ifdef MOMENT
11233                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11234 #else
11235                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11236 #endif
11237                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11238               endif
11239             else
11240 #ifdef MOMENT
11241               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11242 #else
11243               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11244 #endif
11245               if (l.eq.j+1) then
11246                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11247               else
11248                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11249               endif
11250             endif
11251           enddo
11252         enddo
11253       enddo
11254       return
11255       end function eello6_graph4
11256 !-----------------------------------------------------------------------------
11257       real(kind=8) function eello_turn6(i,jj,kk)
11258 !      implicit real*8 (a-h,o-z)
11259 !      include 'DIMENSIONS'
11260 !      include 'COMMON.IOUNITS'
11261 !      include 'COMMON.CHAIN'
11262 !      include 'COMMON.DERIV'
11263 !      include 'COMMON.INTERACT'
11264 !      include 'COMMON.CONTACTS'
11265 !      include 'COMMON.TORSION'
11266 !      include 'COMMON.VAR'
11267 !      include 'COMMON.GEO'
11268       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
11269       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
11270       real(kind=8),dimension(3) :: ggg1,ggg2
11271       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
11272       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
11273 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11274 !           the respective energy moment and not to the cluster cumulant.
11275 !el local variables
11276       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
11277       integer :: j1,j2,l1,l2,ll
11278       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
11279       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
11280       s1=0.0d0
11281       s8=0.0d0
11282       s13=0.0d0
11283 !
11284       eello_turn6=0.0d0
11285       j=i+4
11286       k=i+1
11287       l=i+3
11288       iti=itortyp(itype(i,1))
11289       itk=itortyp(itype(k,1))
11290       itk1=itortyp(itype(k+1,1))
11291       itl=itortyp(itype(l,1))
11292       itj=itortyp(itype(j,1))
11293 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11294 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
11295 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11296 !d        eello6=0.0d0
11297 !d        return
11298 !d      endif
11299 !d      write (iout,*)
11300 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11301 !d     &   ' and',k,l
11302 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
11303       do iii=1,2
11304         do kkk=1,5
11305           do lll=1,3
11306             derx_turn(lll,kkk,iii)=0.0d0
11307           enddo
11308         enddo
11309       enddo
11310 !d      eij=1.0d0
11311 !d      ekl=1.0d0
11312 !d      ekont=1.0d0
11313       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11314 !d      eello6_5=0.0d0
11315 !d      write (2,*) 'eello6_5',eello6_5
11316 #ifdef MOMENT
11317       call transpose2(AEA(1,1,1),auxmat(1,1))
11318       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11319       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
11320       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11321 #endif
11322       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
11323       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11324       s2 = scalar2(b1(1,itk),vtemp1(1))
11325 #ifdef MOMENT
11326       call transpose2(AEA(1,1,2),atemp(1,1))
11327       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11328       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
11329       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11330 #endif
11331       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11332       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11333       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11334 #ifdef MOMENT
11335       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11336       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11337       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11338       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11339       ss13 = scalar2(b1(1,itk),vtemp4(1))
11340       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11341 #endif
11342 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11343 !      s1=0.0d0
11344 !      s2=0.0d0
11345 !      s8=0.0d0
11346 !      s12=0.0d0
11347 !      s13=0.0d0
11348       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11349 ! Derivatives in gamma(i+2)
11350       s1d =0.0d0
11351       s8d =0.0d0
11352 #ifdef MOMENT
11353       call transpose2(AEA(1,1,1),auxmatd(1,1))
11354       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11355       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11356       call transpose2(AEAderg(1,1,2),atempd(1,1))
11357       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11358       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11359 #endif
11360       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11361       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11362       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11363 !      s1d=0.0d0
11364 !      s2d=0.0d0
11365 !      s8d=0.0d0
11366 !      s12d=0.0d0
11367 !      s13d=0.0d0
11368       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11369 ! Derivatives in gamma(i+3)
11370 #ifdef MOMENT
11371       call transpose2(AEA(1,1,1),auxmatd(1,1))
11372       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11373       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
11374       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11375 #endif
11376       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
11377       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11378       s2d = scalar2(b1(1,itk),vtemp1d(1))
11379 #ifdef MOMENT
11380       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
11381       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
11382 #endif
11383       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11384 #ifdef MOMENT
11385       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11386       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11387       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11388 #endif
11389 !      s1d=0.0d0
11390 !      s2d=0.0d0
11391 !      s8d=0.0d0
11392 !      s12d=0.0d0
11393 !      s13d=0.0d0
11394 #ifdef MOMENT
11395       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
11396                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11397 #else
11398       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
11399                     -0.5d0*ekont*(s2d+s12d)
11400 #endif
11401 ! Derivatives in gamma(i+4)
11402       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11403       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11404       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11405 #ifdef MOMENT
11406       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11407       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11408       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11409 #endif
11410 !      s1d=0.0d0
11411 !      s2d=0.0d0
11412 !      s8d=0.0d0
11413 !      s12d=0.0d0
11414 !      s13d=0.0d0
11415 #ifdef MOMENT
11416       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11417 #else
11418       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11419 #endif
11420 ! Derivatives in gamma(i+5)
11421 #ifdef MOMENT
11422       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11423       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11424       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11425 #endif
11426       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
11427       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11428       s2d = scalar2(b1(1,itk),vtemp1d(1))
11429 #ifdef MOMENT
11430       call transpose2(AEA(1,1,2),atempd(1,1))
11431       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11432       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11433 #endif
11434       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11435       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11436 #ifdef MOMENT
11437       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11438       ss13d = scalar2(b1(1,itk),vtemp4d(1))
11439       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11440 #endif
11441 !      s1d=0.0d0
11442 !      s2d=0.0d0
11443 !      s8d=0.0d0
11444 !      s12d=0.0d0
11445 !      s13d=0.0d0
11446 #ifdef MOMENT
11447       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
11448                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11449 #else
11450       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
11451                     -0.5d0*ekont*(s2d+s12d)
11452 #endif
11453 ! Cartesian derivatives
11454       do iii=1,2
11455         do kkk=1,5
11456           do lll=1,3
11457 #ifdef MOMENT
11458             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11459             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11460             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11461 #endif
11462             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
11463             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
11464                 vtemp1d(1))
11465             s2d = scalar2(b1(1,itk),vtemp1d(1))
11466 #ifdef MOMENT
11467             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11468             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11469             s8d = -(atempd(1,1)+atempd(2,2))* &
11470                  scalar2(cc(1,1,itl),vtemp2(1))
11471 #endif
11472             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
11473                  auxmatd(1,1))
11474             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11475             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11476 !      s1d=0.0d0
11477 !      s2d=0.0d0
11478 !      s8d=0.0d0
11479 !      s12d=0.0d0
11480 !      s13d=0.0d0
11481 #ifdef MOMENT
11482             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
11483               - 0.5d0*(s1d+s2d)
11484 #else
11485             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
11486               - 0.5d0*s2d
11487 #endif
11488 #ifdef MOMENT
11489             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
11490               - 0.5d0*(s8d+s12d)
11491 #else
11492             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
11493               - 0.5d0*s12d
11494 #endif
11495           enddo
11496         enddo
11497       enddo
11498 #ifdef MOMENT
11499       do kkk=1,5
11500         do lll=1,3
11501           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
11502             achuj_tempd(1,1))
11503           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11504           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11505           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11506           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11507           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
11508             vtemp4d(1))
11509           ss13d = scalar2(b1(1,itk),vtemp4d(1))
11510           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11511           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11512         enddo
11513       enddo
11514 #endif
11515 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11516 !d     &  16*eel_turn6_num
11517 !d      goto 1112
11518       if (j.lt.nres-1) then
11519         j1=j+1
11520         j2=j-1
11521       else
11522         j1=j-1
11523         j2=j-2
11524       endif
11525       if (l.lt.nres-1) then
11526         l1=l+1
11527         l2=l-1
11528       else
11529         l1=l-1
11530         l2=l-2
11531       endif
11532       do ll=1,3
11533 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11534 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11535 !grad        ghalf=0.5d0*ggg1(ll)
11536 !d        ghalf=0.0d0
11537         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11538         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11539         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
11540           +ekont*derx_turn(ll,2,1)
11541         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11542         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
11543           +ekont*derx_turn(ll,4,1)
11544         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11545         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11546         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11547 !grad        ghalf=0.5d0*ggg2(ll)
11548 !d        ghalf=0.0d0
11549         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
11550           +ekont*derx_turn(ll,2,2)
11551         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11552         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
11553           +ekont*derx_turn(ll,4,2)
11554         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11555         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11556         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11557       enddo
11558 !d      goto 1112
11559 !grad      do m=i+1,j-1
11560 !grad        do ll=1,3
11561 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11562 !grad        enddo
11563 !grad      enddo
11564 !grad      do m=k+1,l-1
11565 !grad        do ll=1,3
11566 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11567 !grad        enddo
11568 !grad      enddo
11569 !grad1112  continue
11570 !grad      do m=i+2,j2
11571 !grad        do ll=1,3
11572 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11573 !grad        enddo
11574 !grad      enddo
11575 !grad      do m=k+2,l2
11576 !grad        do ll=1,3
11577 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11578 !grad        enddo
11579 !grad      enddo
11580 !d      do iii=1,nres-3
11581 !d        write (2,*) iii,g_corr6_loc(iii)
11582 !d      enddo
11583       eello_turn6=ekont*eel_turn6
11584 !d      write (2,*) 'ekont',ekont
11585 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
11586       return
11587       end function eello_turn6
11588 !-----------------------------------------------------------------------------
11589       subroutine MATVEC2(A1,V1,V2)
11590 !DIR$ INLINEALWAYS MATVEC2
11591 #ifndef OSF
11592 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11593 #endif
11594 !      implicit real*8 (a-h,o-z)
11595 !      include 'DIMENSIONS'
11596       real(kind=8),dimension(2) :: V1,V2
11597       real(kind=8),dimension(2,2) :: A1
11598       real(kind=8) :: vaux1,vaux2
11599 !      DO 1 I=1,2
11600 !        VI=0.0
11601 !        DO 3 K=1,2
11602 !    3     VI=VI+A1(I,K)*V1(K)
11603 !        Vaux(I)=VI
11604 !    1 CONTINUE
11605
11606       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11607       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11608
11609       v2(1)=vaux1
11610       v2(2)=vaux2
11611       end subroutine MATVEC2
11612 !-----------------------------------------------------------------------------
11613       subroutine MATMAT2(A1,A2,A3)
11614 #ifndef OSF
11615 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11616 #endif
11617 !      implicit real*8 (a-h,o-z)
11618 !      include 'DIMENSIONS'
11619       real(kind=8),dimension(2,2) :: A1,A2,A3
11620       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
11621 !      DIMENSION AI3(2,2)
11622 !        DO  J=1,2
11623 !          A3IJ=0.0
11624 !          DO K=1,2
11625 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11626 !          enddo
11627 !          A3(I,J)=A3IJ
11628 !       enddo
11629 !      enddo
11630
11631       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11632       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11633       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11634       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11635
11636       A3(1,1)=AI3_11
11637       A3(2,1)=AI3_21
11638       A3(1,2)=AI3_12
11639       A3(2,2)=AI3_22
11640       end subroutine MATMAT2
11641 !-----------------------------------------------------------------------------
11642       real(kind=8) function scalar2(u,v)
11643 !DIR$ INLINEALWAYS scalar2
11644       implicit none
11645       real(kind=8),dimension(2) :: u,v
11646       real(kind=8) :: sc
11647       integer :: i
11648       scalar2=u(1)*v(1)+u(2)*v(2)
11649       return
11650       end function scalar2
11651 !-----------------------------------------------------------------------------
11652       subroutine transpose2(a,at)
11653 !DIR$ INLINEALWAYS transpose2
11654 #ifndef OSF
11655 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
11656 #endif
11657       implicit none
11658       real(kind=8),dimension(2,2) :: a,at
11659       at(1,1)=a(1,1)
11660       at(1,2)=a(2,1)
11661       at(2,1)=a(1,2)
11662       at(2,2)=a(2,2)
11663       return
11664       end subroutine transpose2
11665 !-----------------------------------------------------------------------------
11666       subroutine transpose(n,a,at)
11667       implicit none
11668       integer :: n,i,j
11669       real(kind=8),dimension(n,n) :: a,at
11670       do i=1,n
11671         do j=1,n
11672           at(j,i)=a(i,j)
11673         enddo
11674       enddo
11675       return
11676       end subroutine transpose
11677 !-----------------------------------------------------------------------------
11678       subroutine prodmat3(a1,a2,kk,transp,prod)
11679 !DIR$ INLINEALWAYS prodmat3
11680 #ifndef OSF
11681 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
11682 #endif
11683       implicit none
11684       integer :: i,j
11685       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
11686       logical :: transp
11687 !rc      double precision auxmat(2,2),prod_(2,2)
11688
11689       if (transp) then
11690 !rc        call transpose2(kk(1,1),auxmat(1,1))
11691 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11692 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11693
11694            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
11695        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11696            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
11697        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11698            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
11699        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11700            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
11701        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11702
11703       else
11704 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11705 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11706
11707            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
11708         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11709            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
11710         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11711            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
11712         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11713            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
11714         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11715
11716       endif
11717 !      call transpose2(a2(1,1),a2t(1,1))
11718
11719 !rc      print *,transp
11720 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
11721 !rc      print *,((prod(i,j),i=1,2),j=1,2)
11722
11723       return
11724       end subroutine prodmat3
11725 !-----------------------------------------------------------------------------
11726 ! energy_p_new_barrier.F
11727 !-----------------------------------------------------------------------------
11728       subroutine sum_gradient
11729 !      implicit real*8 (a-h,o-z)
11730       use io_base, only: pdbout
11731 !      include 'DIMENSIONS'
11732 #ifndef ISNAN
11733       external proc_proc
11734 #ifdef WINPGI
11735 !MS$ATTRIBUTES C ::  proc_proc
11736 #endif
11737 #endif
11738 #ifdef MPI
11739       include 'mpif.h'
11740 #endif
11741       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
11742                    gloc_scbuf !(3,maxres)
11743
11744       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
11745 !#endif
11746 !el local variables
11747       integer :: i,j,k,ierror,ierr
11748       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
11749                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
11750                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
11751                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
11752                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
11753                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
11754                    gsccorr_max,gsccorrx_max,time00
11755
11756 !      include 'COMMON.SETUP'
11757 !      include 'COMMON.IOUNITS'
11758 !      include 'COMMON.FFIELD'
11759 !      include 'COMMON.DERIV'
11760 !      include 'COMMON.INTERACT'
11761 !      include 'COMMON.SBRIDGE'
11762 !      include 'COMMON.CHAIN'
11763 !      include 'COMMON.VAR'
11764 !      include 'COMMON.CONTROL'
11765 !      include 'COMMON.TIME1'
11766 !      include 'COMMON.MAXGRAD'
11767 !      include 'COMMON.SCCOR'
11768 #ifdef TIMING
11769       time01=MPI_Wtime()
11770 #endif
11771 !#define DEBUG
11772 #ifdef DEBUG
11773       write (iout,*) "sum_gradient gvdwc, gvdwx"
11774       do i=1,nres
11775         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11776          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
11777       enddo
11778       call flush(iout)
11779 #endif
11780 #ifdef MPI
11781         gradbufc=0.0d0
11782         gradbufx=0.0d0
11783         gradbufc_sum=0.0d0
11784         gloc_scbuf=0.0d0
11785         glocbuf=0.0d0
11786 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
11787         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
11788           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
11789 #endif
11790 !
11791 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
11792 !            in virtual-bond-vector coordinates
11793 !
11794 #ifdef DEBUG
11795 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
11796 !      do i=1,nres-1
11797 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
11798 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
11799 !      enddo
11800 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
11801 !      do i=1,nres-1
11802 !        write (iout,'(i5,3f10.5,2x,f10.5)')
11803 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
11804 !      enddo
11805 !      write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
11806 !      do i=1,nres
11807 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11808 !         i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
11809 !         (gvdwc_scpp(j,i),j=1,3)
11810 !      enddo
11811 !      write (iout,*) "gelc_long gvdwpp gel_loc_long"
11812 !      do i=1,nres
11813 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11814 !         i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
11815 !         (gelc_loc_long(j,i),j=1,3)
11816 !      enddo
11817       call flush(iout)
11818 #endif
11819 #ifdef SPLITELE
11820       do i=0,nct
11821         do j=1,3
11822           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11823                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11824                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11825                       wel_loc*gel_loc_long(j,i)+ &
11826                       wcorr*gradcorr_long(j,i)+ &
11827                       wcorr5*gradcorr5_long(j,i)+ &
11828                       wcorr6*gradcorr6_long(j,i)+ &
11829                       wturn6*gcorr6_turn_long(j,i)+ &
11830                       wstrain*ghpbc(j,i) &
11831                      +wliptran*gliptranc(j,i) &
11832                      +gradafm(j,i) &
11833                      +welec*gshieldc(j,i) &
11834                      +wcorr*gshieldc_ec(j,i) &
11835                      +wturn3*gshieldc_t3(j,i)&
11836                      +wturn4*gshieldc_t4(j,i)&
11837                      +wel_loc*gshieldc_ll(j,i)&
11838                      +wtube*gg_tube(j,i) &
11839                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11840                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11841                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11842                      wcorr_nucl*gradcorr_nucl(j,i)&
11843                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
11844                      wcatprot* gradpepcat(j,i)+ &
11845                      wcatcat*gradcatcat(j,i)+   &
11846                      wscbase*gvdwc_scbase(j,i)+ &
11847                      wpepbase*gvdwc_pepbase(j,i)+&
11848                      wscpho*gvdwc_scpho(j,i)+   &
11849                      wpeppho*gvdwc_peppho(j,i)+wcatnucl*gradnuclcat(j,i)
11850
11851
11852
11853
11854
11855         enddo
11856       enddo
11857 #else
11858       do i=0,nct
11859         do j=1,3
11860           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11861                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11862                       welec*gelc_long(j,i)+ &
11863                       wbond*gradb(j,i)+ &
11864                       wel_loc*gel_loc_long(j,i)+ &
11865                       wcorr*gradcorr_long(j,i)+ &
11866                       wcorr5*gradcorr5_long(j,i)+ &
11867                       wcorr6*gradcorr6_long(j,i)+ &
11868                       wturn6*gcorr6_turn_long(j,i)+ &
11869                       wstrain*ghpbc(j,i) &
11870                      +wliptran*gliptranc(j,i) &
11871                      +gradafm(j,i) &
11872                      +welec*gshieldc(j,i)&
11873                      +wcorr*gshieldc_ec(j,i) &
11874                      +wturn4*gshieldc_t4(j,i) &
11875                      +wel_loc*gshieldc_ll(j,i)&
11876                      +wtube*gg_tube(j,i) &
11877                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11878                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11879                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11880                      wcorr_nucl*gradcorr_nucl(j,i) &
11881                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
11882                      wcatprot* gradpepcat(j,i)+ &
11883                      wcatcat*gradcatcat(j,i)+   &
11884                      wscbase*gvdwc_scbase(j,i)+ &
11885                      wpepbase*gvdwc_pepbase(j,i)+&
11886                      wscpho*gvdwc_scpho(j,i)+&
11887                      wpeppho*gvdwc_peppho(j,i)+wcatnucl*gradnuclcat(j,i)
11888
11889
11890         enddo
11891       enddo
11892 #endif
11893 #ifdef MPI
11894       if (nfgtasks.gt.1) then
11895       time00=MPI_Wtime()
11896 #ifdef DEBUG
11897       write (iout,*) "gradbufc before allreduce"
11898       do i=1,nres
11899         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11900       enddo
11901       call flush(iout)
11902 #endif
11903       do i=0,nres
11904         do j=1,3
11905           gradbufc_sum(j,i)=gradbufc(j,i)
11906         enddo
11907       enddo
11908 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
11909 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11910 !      time_reduce=time_reduce+MPI_Wtime()-time00
11911 #ifdef DEBUG
11912 !      write (iout,*) "gradbufc_sum after allreduce"
11913 !      do i=1,nres
11914 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
11915 !      enddo
11916 !      call flush(iout)
11917 #endif
11918 #ifdef TIMING
11919 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
11920 #endif
11921       do i=0,nres
11922         do k=1,3
11923           gradbufc(k,i)=0.0d0
11924         enddo
11925       enddo
11926 #ifdef DEBUG
11927       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
11928       write (iout,*) (i," jgrad_start",jgrad_start(i),&
11929                         " jgrad_end  ",jgrad_end(i),&
11930                         i=igrad_start,igrad_end)
11931 #endif
11932 !
11933 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
11934 ! do not parallelize this part.
11935 !
11936 !      do i=igrad_start,igrad_end
11937 !        do j=jgrad_start(i),jgrad_end(i)
11938 !          do k=1,3
11939 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
11940 !          enddo
11941 !        enddo
11942 !      enddo
11943       do j=1,3
11944         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11945       enddo
11946       do i=nres-2,-1,-1
11947         do j=1,3
11948           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11949         enddo
11950       enddo
11951 #ifdef DEBUG
11952       write (iout,*) "gradbufc after summing"
11953       do i=1,nres
11954         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11955       enddo
11956       call flush(iout)
11957 #endif
11958       else
11959 #endif
11960 !el#define DEBUG
11961 #ifdef DEBUG
11962       write (iout,*) "gradbufc"
11963       do i=1,nres
11964         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11965       enddo
11966       call flush(iout)
11967 #endif
11968 !el#undef DEBUG
11969       do i=-1,nres
11970         do j=1,3
11971           gradbufc_sum(j,i)=gradbufc(j,i)
11972           gradbufc(j,i)=0.0d0
11973         enddo
11974       enddo
11975       do j=1,3
11976         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11977       enddo
11978       do i=nres-2,-1,-1
11979         do j=1,3
11980           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11981         enddo
11982       enddo
11983 !      do i=nnt,nres-1
11984 !        do k=1,3
11985 !          gradbufc(k,i)=0.0d0
11986 !        enddo
11987 !        do j=i+1,nres
11988 !          do k=1,3
11989 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
11990 !          enddo
11991 !        enddo
11992 !      enddo
11993 !el#define DEBUG
11994 #ifdef DEBUG
11995       write (iout,*) "gradbufc after summing"
11996       do i=1,nres
11997         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11998       enddo
11999       call flush(iout)
12000 #endif
12001 !el#undef DEBUG
12002 #ifdef MPI
12003       endif
12004 #endif
12005       do k=1,3
12006         gradbufc(k,nres)=0.0d0
12007       enddo
12008 !el----------------
12009 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
12010 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
12011 !el-----------------
12012       do i=-1,nct
12013         do j=1,3
12014 #ifdef SPLITELE
12015           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
12016                       wel_loc*gel_loc(j,i)+ &
12017                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
12018                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
12019                       wel_loc*gel_loc_long(j,i)+ &
12020                       wcorr*gradcorr_long(j,i)+ &
12021                       wcorr5*gradcorr5_long(j,i)+ &
12022                       wcorr6*gradcorr6_long(j,i)+ &
12023                       wturn6*gcorr6_turn_long(j,i))+ &
12024                       wbond*gradb(j,i)+ &
12025                       wcorr*gradcorr(j,i)+ &
12026                       wturn3*gcorr3_turn(j,i)+ &
12027                       wturn4*gcorr4_turn(j,i)+ &
12028                       wcorr5*gradcorr5(j,i)+ &
12029                       wcorr6*gradcorr6(j,i)+ &
12030                       wturn6*gcorr6_turn(j,i)+ &
12031                       wsccor*gsccorc(j,i) &
12032                      +wscloc*gscloc(j,i)  &
12033                      +wliptran*gliptranc(j,i) &
12034                      +gradafm(j,i) &
12035                      +welec*gshieldc(j,i) &
12036                      +welec*gshieldc_loc(j,i) &
12037                      +wcorr*gshieldc_ec(j,i) &
12038                      +wcorr*gshieldc_loc_ec(j,i) &
12039                      +wturn3*gshieldc_t3(j,i) &
12040                      +wturn3*gshieldc_loc_t3(j,i) &
12041                      +wturn4*gshieldc_t4(j,i) &
12042                      +wturn4*gshieldc_loc_t4(j,i) &
12043                      +wel_loc*gshieldc_ll(j,i) &
12044                      +wel_loc*gshieldc_loc_ll(j,i) &
12045                      +wtube*gg_tube(j,i) &
12046                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
12047                      +wvdwpsb*gvdwpsb1(j,i))&
12048                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
12049 !                      if (i.eq.21) then
12050 !                      print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),&
12051 !                      wturn4*gshieldc_t4(j,i), &
12052 !                     wturn4*gshieldc_loc_t4(j,i)
12053 !                       endif
12054 !                 if ((i.le.2).and.(i.ge.1))
12055 !                       print *,gradc(j,i,icg),&
12056 !                      gradbufc(j,i),welec*gelc(j,i), &
12057 !                      wel_loc*gel_loc(j,i), &
12058 !                      wscp*gvdwc_scpp(j,i), &
12059 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
12060 !                      wel_loc*gel_loc_long(j,i), &
12061 !                      wcorr*gradcorr_long(j,i), &
12062 !                      wcorr5*gradcorr5_long(j,i), &
12063 !                      wcorr6*gradcorr6_long(j,i), &
12064 !                      wturn6*gcorr6_turn_long(j,i), &
12065 !                      wbond*gradb(j,i), &
12066 !                      wcorr*gradcorr(j,i), &
12067 !                      wturn3*gcorr3_turn(j,i), &
12068 !                      wturn4*gcorr4_turn(j,i), &
12069 !                      wcorr5*gradcorr5(j,i), &
12070 !                      wcorr6*gradcorr6(j,i), &
12071 !                      wturn6*gcorr6_turn(j,i), &
12072 !                      wsccor*gsccorc(j,i) &
12073 !                     ,wscloc*gscloc(j,i)  &
12074 !                     ,wliptran*gliptranc(j,i) &
12075 !                    ,gradafm(j,i) &
12076 !                     ,welec*gshieldc(j,i) &
12077 !                     ,welec*gshieldc_loc(j,i) &
12078 !                     ,wcorr*gshieldc_ec(j,i) &
12079 !                     ,wcorr*gshieldc_loc_ec(j,i) &
12080 !                     ,wturn3*gshieldc_t3(j,i) &
12081 !                     ,wturn3*gshieldc_loc_t3(j,i) &
12082 !                     ,wturn4*gshieldc_t4(j,i) &
12083 !                     ,wturn4*gshieldc_loc_t4(j,i) &
12084 !                     ,wel_loc*gshieldc_ll(j,i) &
12085 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
12086 !                     ,wtube*gg_tube(j,i) &
12087 !                     ,wbond_nucl*gradb_nucl(j,i) &
12088 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
12089 !                     wvdwpsb*gvdwpsb1(j,i)&
12090 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
12091 !
12092
12093 #else
12094           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
12095                       wel_loc*gel_loc(j,i)+ &
12096                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
12097                       welec*gelc_long(j,i)+ &
12098                       wel_loc*gel_loc_long(j,i)+ &
12099 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
12100                       wcorr5*gradcorr5_long(j,i)+ &
12101                       wcorr6*gradcorr6_long(j,i)+ &
12102                       wturn6*gcorr6_turn_long(j,i))+ &
12103                       wbond*gradb(j,i)+ &
12104                       wcorr*gradcorr(j,i)+ &
12105                       wturn3*gcorr3_turn(j,i)+ &
12106                       wturn4*gcorr4_turn(j,i)+ &
12107                       wcorr5*gradcorr5(j,i)+ &
12108                       wcorr6*gradcorr6(j,i)+ &
12109                       wturn6*gcorr6_turn(j,i)+ &
12110                       wsccor*gsccorc(j,i) &
12111                      +wscloc*gscloc(j,i) &
12112                      +gradafm(j,i) &
12113                      +wliptran*gliptranc(j,i) &
12114                      +welec*gshieldc(j,i) &
12115                      +welec*gshieldc_loc(j,i) &
12116                      +wcorr*gshieldc_ec(j,i) &
12117                      +wcorr*gshieldc_loc_ec(j,i) &
12118                      +wturn3*gshieldc_t3(j,i) &
12119                      +wturn3*gshieldc_loc_t3(j,i) &
12120                      +wturn4*gshieldc_t4(j,i) &
12121                      +wturn4*gshieldc_loc_t4(j,i) &
12122                      +wel_loc*gshieldc_ll(j,i) &
12123                      +wel_loc*gshieldc_loc_ll(j,i) &
12124                      +wtube*gg_tube(j,i) &
12125                      +wbond_nucl*gradb_nucl(j,i) &
12126                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
12127                      +wvdwpsb*gvdwpsb1(j,i))&
12128                      +wsbloc*gsbloc(j,i)+wcatnucl*gradnuclcat(j,i)
12129
12130
12131
12132
12133 #endif
12134           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
12135                         wbond*gradbx(j,i)+ &
12136                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
12137                         wsccor*gsccorx(j,i) &
12138                        +wscloc*gsclocx(j,i) &
12139                        +wliptran*gliptranx(j,i) &
12140                        +welec*gshieldx(j,i)     &
12141                        +wcorr*gshieldx_ec(j,i)  &
12142                        +wturn3*gshieldx_t3(j,i) &
12143                        +wturn4*gshieldx_t4(j,i) &
12144                        +wel_loc*gshieldx_ll(j,i)&
12145                        +wtube*gg_tube_sc(j,i)   &
12146                        +wbond_nucl*gradbx_nucl(j,i) &
12147                        +wvdwsb*gvdwsbx(j,i) &
12148                        +welsb*gelsbx(j,i) &
12149                        +wcorr_nucl*gradxorr_nucl(j,i)&
12150                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
12151                        +wsbloc*gsblocx(j,i) &
12152                        +wcatprot* gradpepcatx(j,i)&
12153                        +wscbase*gvdwx_scbase(j,i) &
12154                        +wpepbase*gvdwx_pepbase(j,i)&
12155                        +wscpho*gvdwx_scpho(j,i)+wcatnucl*gradnuclcatx(j,i)
12156 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
12157
12158         enddo
12159       enddo
12160 !      write(iout,*), "const_homol",constr_homology
12161       if (constr_homology.gt.0) then
12162         do i=1,nct
12163           do j=1,3
12164             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
12165 !            write(iout,*) "duscdiff",duscdiff(j,i)
12166             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
12167           enddo
12168         enddo
12169       endif
12170 !#define DEBUG
12171 #ifdef DEBUG
12172       write (iout,*) "gloc before adding corr"
12173       do i=1,4*nres
12174         write (iout,*) i,gloc(i,icg)
12175       enddo
12176 #endif
12177       do i=1,nres-3
12178         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
12179          +wcorr5*g_corr5_loc(i) &
12180          +wcorr6*g_corr6_loc(i) &
12181          +wturn4*gel_loc_turn4(i) &
12182          +wturn3*gel_loc_turn3(i) &
12183          +wturn6*gel_loc_turn6(i) &
12184          +wel_loc*gel_loc_loc(i)
12185       enddo
12186 #ifdef DEBUG
12187       write (iout,*) "gloc after adding corr"
12188       do i=1,4*nres
12189         write (iout,*) i,gloc(i,icg)
12190       enddo
12191 #endif
12192 !#undef DEBUG
12193 #ifdef MPI
12194       if (nfgtasks.gt.1) then
12195         do j=1,3
12196           do i=0,nres
12197             gradbufc(j,i)=gradc(j,i,icg)
12198             gradbufx(j,i)=gradx(j,i,icg)
12199           enddo
12200         enddo
12201         do i=1,4*nres
12202           glocbuf(i)=gloc(i,icg)
12203         enddo
12204 !#define DEBUG
12205 #ifdef DEBUG
12206       write (iout,*) "gloc_sc before reduce"
12207       do i=1,nres
12208        do j=1,1
12209         write (iout,*) i,j,gloc_sc(j,i,icg)
12210        enddo
12211       enddo
12212 #endif
12213 !#undef DEBUG
12214         do i=0,nres
12215          do j=1,3
12216           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
12217          enddo
12218         enddo
12219         time00=MPI_Wtime()
12220         call MPI_Barrier(FG_COMM,IERR)
12221         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
12222         time00=MPI_Wtime()
12223         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
12224           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12225         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
12226           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12227         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
12228           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12229         time_reduce=time_reduce+MPI_Wtime()-time00
12230         call MPI_Reduce(gloc_scbuf(1,0),gloc_sc(1,0,icg),3*nres+3,&
12231           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12232         time_reduce=time_reduce+MPI_Wtime()-time00
12233 !#define DEBUG
12234 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
12235 #ifdef DEBUG
12236       write (iout,*) "gloc_sc after reduce"
12237       do i=0,nres
12238        do j=1,1
12239         write (iout,*) i,j,gloc_sc(j,i,icg)
12240        enddo
12241       enddo
12242 #endif
12243 !#undef DEBUG
12244 #ifdef DEBUG
12245       write (iout,*) "gloc after reduce"
12246       do i=1,4*nres
12247         write (iout,*) i,gloc(i,icg)
12248       enddo
12249 #endif
12250       endif
12251 #endif
12252       if (gnorm_check) then
12253 !
12254 ! Compute the maximum elements of the gradient
12255 !
12256       gvdwc_max=0.0d0
12257       gvdwc_scp_max=0.0d0
12258       gelc_max=0.0d0
12259       gvdwpp_max=0.0d0
12260       gradb_max=0.0d0
12261       ghpbc_max=0.0d0
12262       gradcorr_max=0.0d0
12263       gel_loc_max=0.0d0
12264       gcorr3_turn_max=0.0d0
12265       gcorr4_turn_max=0.0d0
12266       gradcorr5_max=0.0d0
12267       gradcorr6_max=0.0d0
12268       gcorr6_turn_max=0.0d0
12269       gsccorc_max=0.0d0
12270       gscloc_max=0.0d0
12271       gvdwx_max=0.0d0
12272       gradx_scp_max=0.0d0
12273       ghpbx_max=0.0d0
12274       gradxorr_max=0.0d0
12275       gsccorx_max=0.0d0
12276       gsclocx_max=0.0d0
12277       do i=1,nct
12278         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
12279         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
12280         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
12281         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
12282          gvdwc_scp_max=gvdwc_scp_norm
12283         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
12284         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
12285         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
12286         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
12287         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
12288         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
12289         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
12290         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
12291         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
12292         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
12293         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
12294         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
12295         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
12296           gcorr3_turn(1,i)))
12297         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
12298           gcorr3_turn_max=gcorr3_turn_norm
12299         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
12300           gcorr4_turn(1,i)))
12301         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
12302           gcorr4_turn_max=gcorr4_turn_norm
12303         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
12304         if (gradcorr5_norm.gt.gradcorr5_max) &
12305           gradcorr5_max=gradcorr5_norm
12306         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
12307         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
12308         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
12309           gcorr6_turn(1,i)))
12310         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
12311           gcorr6_turn_max=gcorr6_turn_norm
12312         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
12313         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
12314         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
12315         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
12316         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
12317         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
12318         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
12319         if (gradx_scp_norm.gt.gradx_scp_max) &
12320           gradx_scp_max=gradx_scp_norm
12321         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
12322         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
12323         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
12324         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
12325         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
12326         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
12327         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
12328         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
12329       enddo
12330       if (gradout) then
12331 #ifdef AIX
12332         open(istat,file=statname,position="append")
12333 #else
12334         open(istat,file=statname,access="append")
12335 #endif
12336         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
12337            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
12338            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
12339            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
12340            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
12341            gsccorx_max,gsclocx_max
12342         close(istat)
12343         if (gvdwc_max.gt.1.0d4) then
12344           write (iout,*) "gvdwc gvdwx gradb gradbx"
12345           do i=nnt,nct
12346             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
12347               gradb(j,i),gradbx(j,i),j=1,3)
12348           enddo
12349           call pdbout(0.0d0,'cipiszcze',iout)
12350           call flush(iout)
12351         endif
12352       endif
12353       endif
12354 !#define DEBUG
12355 #ifdef DEBUG
12356       write (iout,*) "gradc gradx gloc"
12357       do i=1,nres
12358         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
12359          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
12360       enddo
12361 #endif
12362 !#undef DEBUG
12363 #ifdef TIMING
12364       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
12365 #endif
12366       return
12367       end subroutine sum_gradient
12368 !-----------------------------------------------------------------------------
12369       subroutine sc_grad
12370 !      implicit real*8 (a-h,o-z)
12371       use calc_data
12372 !      include 'DIMENSIONS'
12373 !      include 'COMMON.CHAIN'
12374 !      include 'COMMON.DERIV'
12375 !      include 'COMMON.CALC'
12376 !      include 'COMMON.IOUNITS'
12377       real(kind=8), dimension(3) :: dcosom1,dcosom2
12378 !      print *,"wchodze"
12379       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
12380           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
12381       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
12382           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
12383
12384       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
12385            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
12386            +dCAVdOM12+ dGCLdOM12
12387 ! diagnostics only
12388 !      eom1=0.0d0
12389 !      eom2=0.0d0
12390 !      eom12=evdwij*eps1_om12
12391 ! end diagnostics
12392 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
12393 !       " sigder",sigder
12394 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
12395 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
12396 !C      print *,sss_ele_cut,'in sc_grad'
12397       do k=1,3
12398         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
12399         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
12400       enddo
12401       do k=1,3
12402         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
12403 !C      print *,'gg',k,gg(k)
12404        enddo
12405 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
12406 !      write (iout,*) "gg",(gg(k),k=1,3)
12407       do k=1,3
12408         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
12409                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
12410                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
12411                   *sss_ele_cut
12412
12413         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
12414                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
12415                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
12416                   *sss_ele_cut
12417
12418 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
12419 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
12420 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
12421 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
12422       enddo
12423 !
12424 ! Calculate the components of the gradient in DC and X
12425 !
12426 !grad      do k=i,j-1
12427 !grad        do l=1,3
12428 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
12429 !grad        enddo
12430 !grad      enddo
12431       do l=1,3
12432         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
12433         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
12434       enddo
12435       return
12436       end subroutine sc_grad
12437
12438       subroutine sc_grad_cat
12439       use calc_data
12440       real(kind=8), dimension(3) :: dcosom1,dcosom2
12441       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
12442           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
12443       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
12444           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
12445
12446       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
12447            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
12448            +dCAVdOM12+ dGCLdOM12
12449 ! diagnostics only
12450 !      eom1=0.0d0
12451 !      eom2=0.0d0
12452 !      eom12=evdwij*eps1_om12
12453 ! end diagnostics
12454
12455       do k=1,3
12456         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
12457         dcosom2(k)=rij*(dc_norm(k,j)-om2*erij(k))
12458       enddo
12459       do k=1,3
12460         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))
12461 !      print *,'gg',k,gg(k)
12462        enddo
12463 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
12464 !      write (iout,*) "gg",(gg(k),k=1,3)
12465       do k=1,3
12466         gradpepcatx(k,i)=gradpepcatx(k,i)-gg(k) &
12467                   +(eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
12468                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
12469
12470 !        gradpepcatx(k,j)=gradpepcatx(k,j)+gg(k) &
12471 !                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)) &
12472 !                  +eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv
12473
12474 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
12475 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
12476 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
12477 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
12478       enddo
12479 !
12480 ! Calculate the components of the gradient in DC and X
12481 !
12482       do l=1,3
12483         gradpepcat(l,i)=gradpepcat(l,i)-gg(l)
12484         gradpepcat(l,j)=gradpepcat(l,j)+gg(l)
12485       enddo
12486       end subroutine sc_grad_cat
12487
12488       subroutine sc_grad_cat_pep
12489       use calc_data
12490       real(kind=8), dimension(3) :: dcosom1,dcosom2
12491       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
12492           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
12493       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
12494           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
12495
12496       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
12497            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
12498            +dCAVdOM12+ dGCLdOM12
12499 ! diagnostics only
12500 !      eom1=0.0d0
12501 !      eom2=0.0d0
12502 !      eom12=evdwij*eps1_om12
12503 ! end diagnostics
12504
12505       do k=1,3
12506         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
12507         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
12508         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
12509         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
12510                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
12511                  *dsci_inv*2.0 &
12512                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
12513         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
12514                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
12515                  *dsci_inv*2.0 &
12516                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
12517         gradpepcat(k,j)=gradpepcat(k,j)+gg(k)
12518       enddo
12519       end subroutine sc_grad_cat_pep
12520
12521 #ifdef CRYST_THETA
12522 !-----------------------------------------------------------------------------
12523       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
12524
12525       use comm_calcthet
12526 !      implicit real*8 (a-h,o-z)
12527 !      include 'DIMENSIONS'
12528 !      include 'COMMON.LOCAL'
12529 !      include 'COMMON.IOUNITS'
12530 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
12531 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
12532 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
12533       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
12534       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
12535 !el      integer :: it
12536 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
12537 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
12538 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
12539 !el local variables
12540
12541       delthec=thetai-thet_pred_mean
12542       delthe0=thetai-theta0i
12543 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
12544       t3 = thetai-thet_pred_mean
12545       t6 = t3**2
12546       t9 = term1
12547       t12 = t3*sigcsq
12548       t14 = t12+t6*sigsqtc
12549       t16 = 1.0d0
12550       t21 = thetai-theta0i
12551       t23 = t21**2
12552       t26 = term2
12553       t27 = t21*t26
12554       t32 = termexp
12555       t40 = t32**2
12556       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
12557        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
12558        *(-t12*t9-ak*sig0inv*t27)
12559       return
12560       end subroutine mixder
12561 #endif
12562 !-----------------------------------------------------------------------------
12563 ! cartder.F
12564 !-----------------------------------------------------------------------------
12565       subroutine cartder
12566 !-----------------------------------------------------------------------------
12567 ! This subroutine calculates the derivatives of the consecutive virtual
12568 ! bond vectors and the SC vectors in the virtual-bond angles theta and
12569 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
12570 ! in the angles alpha and omega, describing the location of a side chain
12571 ! in its local coordinate system.
12572 !
12573 ! The derivatives are stored in the following arrays:
12574 !
12575 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
12576 ! The structure is as follows:
12577 !
12578 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
12579 ! 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)
12580 !         . . . . . . . . . . . .  . . . . . .
12581 ! 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)
12582 !                          .
12583 !                          .
12584 !                          .
12585 ! 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)
12586 !
12587 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
12588 ! The structure is same as above.
12589 !
12590 ! DCDS - the derivatives of the side chain vectors in the local spherical
12591 ! andgles alph and omega:
12592 !
12593 ! 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)
12594 ! 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)
12595 !                          .
12596 !                          .
12597 !                          .
12598 ! 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)
12599 !
12600 ! Version of March '95, based on an early version of November '91.
12601 !
12602 !**********************************************************************
12603 !      implicit real*8 (a-h,o-z)
12604 !      include 'DIMENSIONS'
12605 !      include 'COMMON.VAR'
12606 !      include 'COMMON.CHAIN'
12607 !      include 'COMMON.DERIV'
12608 !      include 'COMMON.GEO'
12609 !      include 'COMMON.LOCAL'
12610 !      include 'COMMON.INTERACT'
12611       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
12612       real(kind=8),dimension(3,3) :: dp,temp
12613 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
12614       real(kind=8),dimension(3) :: xx,xx1
12615 !el local variables
12616       integer :: i,k,l,j,m,ind,ind1,jjj
12617       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
12618                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
12619                  sint2,xp,yp,xxp,yyp,zzp,dj
12620
12621 !      common /przechowalnia/ fromto
12622       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
12623 ! get the position of the jth ijth fragment of the chain coordinate system
12624 ! in the fromto array.
12625 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12626 !
12627 !      maxdim=(nres-1)*(nres-2)/2
12628 !      allocate(dcdv(6,maxdim),dxds(6,nres))
12629 ! calculate the derivatives of transformation matrix elements in theta
12630 !
12631
12632 !el      call flush(iout) !el
12633       do i=1,nres-2
12634         rdt(1,1,i)=-rt(1,2,i)
12635         rdt(1,2,i)= rt(1,1,i)
12636         rdt(1,3,i)= 0.0d0
12637         rdt(2,1,i)=-rt(2,2,i)
12638         rdt(2,2,i)= rt(2,1,i)
12639         rdt(2,3,i)= 0.0d0
12640         rdt(3,1,i)=-rt(3,2,i)
12641         rdt(3,2,i)= rt(3,1,i)
12642         rdt(3,3,i)= 0.0d0
12643       enddo
12644 !
12645 ! derivatives in phi
12646 !
12647       do i=2,nres-2
12648         drt(1,1,i)= 0.0d0
12649         drt(1,2,i)= 0.0d0
12650         drt(1,3,i)= 0.0d0
12651         drt(2,1,i)= rt(3,1,i)
12652         drt(2,2,i)= rt(3,2,i)
12653         drt(2,3,i)= rt(3,3,i)
12654         drt(3,1,i)=-rt(2,1,i)
12655         drt(3,2,i)=-rt(2,2,i)
12656         drt(3,3,i)=-rt(2,3,i)
12657       enddo
12658 !
12659 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
12660 !
12661       do i=2,nres-2
12662         ind=indmat(i,i+1)
12663         do k=1,3
12664           do l=1,3
12665             temp(k,l)=rt(k,l,i)
12666           enddo
12667         enddo
12668         do k=1,3
12669           do l=1,3
12670             fromto(k,l,ind)=temp(k,l)
12671           enddo
12672         enddo
12673         do j=i+1,nres-2
12674           ind=indmat(i,j+1)
12675           do k=1,3
12676             do l=1,3
12677               dpkl=0.0d0
12678               do m=1,3
12679                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
12680               enddo
12681               dp(k,l)=dpkl
12682               fromto(k,l,ind)=dpkl
12683             enddo
12684           enddo
12685           do k=1,3
12686             do l=1,3
12687               temp(k,l)=dp(k,l)
12688             enddo
12689           enddo
12690         enddo
12691       enddo
12692 !
12693 ! Calculate derivatives.
12694 !
12695       ind1=0
12696       do i=1,nres-2
12697       ind1=ind1+1
12698 !
12699 ! Derivatives of DC(i+1) in theta(i+2)
12700 !
12701         do j=1,3
12702           do k=1,2
12703             dpjk=0.0D0
12704             do l=1,3
12705               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
12706             enddo
12707             dp(j,k)=dpjk
12708             prordt(j,k,i)=dp(j,k)
12709           enddo
12710           dp(j,3)=0.0D0
12711           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
12712         enddo
12713 !
12714 ! Derivatives of SC(i+1) in theta(i+2)
12715 !
12716         xx1(1)=-0.5D0*xloc(2,i+1)
12717         xx1(2)= 0.5D0*xloc(1,i+1)
12718         do j=1,3
12719           xj=0.0D0
12720           do k=1,2
12721             xj=xj+r(j,k,i)*xx1(k)
12722           enddo
12723           xx(j)=xj
12724         enddo
12725         do j=1,3
12726           rj=0.0D0
12727           do k=1,3
12728             rj=rj+prod(j,k,i)*xx(k)
12729           enddo
12730           dxdv(j,ind1)=rj
12731         enddo
12732 !
12733 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
12734 ! than the other off-diagonal derivatives.
12735 !
12736         do j=1,3
12737           dxoiij=0.0D0
12738           do k=1,3
12739             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12740           enddo
12741           dxdv(j,ind1+1)=dxoiij
12742         enddo
12743 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
12744 !
12745 ! Derivatives of DC(i+1) in phi(i+2)
12746 !
12747         do j=1,3
12748           do k=1,3
12749             dpjk=0.0
12750             do l=2,3
12751               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
12752             enddo
12753             dp(j,k)=dpjk
12754             prodrt(j,k,i)=dp(j,k)
12755           enddo
12756           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
12757         enddo
12758 !
12759 ! Derivatives of SC(i+1) in phi(i+2)
12760 !
12761         xx(1)= 0.0D0
12762         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
12763         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
12764         do j=1,3
12765           rj=0.0D0
12766           do k=2,3
12767             rj=rj+prod(j,k,i)*xx(k)
12768           enddo
12769           dxdv(j+3,ind1)=-rj
12770         enddo
12771 !
12772 ! Derivatives of SC(i+1) in phi(i+3).
12773 !
12774         do j=1,3
12775           dxoiij=0.0D0
12776           do k=1,3
12777             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12778           enddo
12779           dxdv(j+3,ind1+1)=dxoiij
12780         enddo
12781 !
12782 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
12783 ! theta(nres) and phi(i+3) thru phi(nres).
12784 !
12785         do j=i+1,nres-2
12786         ind1=ind1+1
12787         ind=indmat(i+1,j+1)
12788 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
12789           do k=1,3
12790             do l=1,3
12791               tempkl=0.0D0
12792               do m=1,2
12793                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
12794               enddo
12795               temp(k,l)=tempkl
12796             enddo
12797           enddo
12798 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
12799 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
12800 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
12801 ! Derivatives of virtual-bond vectors in theta
12802           do k=1,3
12803             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
12804           enddo
12805 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
12806 ! Derivatives of SC vectors in theta
12807           do k=1,3
12808             dxoijk=0.0D0
12809             do l=1,3
12810               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12811             enddo
12812             dxdv(k,ind1+1)=dxoijk
12813           enddo
12814 !
12815 !--- Calculate the derivatives in phi
12816 !
12817           do k=1,3
12818             do l=1,3
12819               tempkl=0.0D0
12820               do m=1,3
12821                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
12822               enddo
12823               temp(k,l)=tempkl
12824             enddo
12825           enddo
12826           do k=1,3
12827             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
12828         enddo
12829           do k=1,3
12830             dxoijk=0.0D0
12831             do l=1,3
12832               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12833             enddo
12834             dxdv(k+3,ind1+1)=dxoijk
12835           enddo
12836         enddo
12837       enddo
12838 !
12839 ! Derivatives in alpha and omega:
12840 !
12841       do i=2,nres-1
12842 !       dsci=dsc(itype(i,1))
12843         dsci=vbld(i+nres)
12844 #ifdef OSF
12845         alphi=alph(i)
12846         omegi=omeg(i)
12847         if(alphi.ne.alphi) alphi=100.0
12848         if(omegi.ne.omegi) omegi=-100.0
12849 #else
12850       alphi=alph(i)
12851       omegi=omeg(i)
12852 #endif
12853 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
12854       cosalphi=dcos(alphi)
12855       sinalphi=dsin(alphi)
12856       cosomegi=dcos(omegi)
12857       sinomegi=dsin(omegi)
12858       temp(1,1)=-dsci*sinalphi
12859       temp(2,1)= dsci*cosalphi*cosomegi
12860       temp(3,1)=-dsci*cosalphi*sinomegi
12861       temp(1,2)=0.0D0
12862       temp(2,2)=-dsci*sinalphi*sinomegi
12863       temp(3,2)=-dsci*sinalphi*cosomegi
12864       theta2=pi-0.5D0*theta(i+1)
12865       cost2=dcos(theta2)
12866       sint2=dsin(theta2)
12867       jjj=0
12868 !d      print *,((temp(l,k),l=1,3),k=1,2)
12869         do j=1,2
12870         xp=temp(1,j)
12871         yp=temp(2,j)
12872         xxp= xp*cost2+yp*sint2
12873         yyp=-xp*sint2+yp*cost2
12874         zzp=temp(3,j)
12875         xx(1)=xxp
12876         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
12877         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
12878         do k=1,3
12879           dj=0.0D0
12880           do l=1,3
12881             dj=dj+prod(k,l,i-1)*xx(l)
12882             enddo
12883           dxds(jjj+k,i)=dj
12884           enddo
12885         jjj=jjj+3
12886       enddo
12887       enddo
12888       return
12889       end subroutine cartder
12890 !-----------------------------------------------------------------------------
12891 ! checkder_p.F
12892 !-----------------------------------------------------------------------------
12893       subroutine check_cartgrad
12894 ! Check the gradient of Cartesian coordinates in internal coordinates.
12895 !      implicit real*8 (a-h,o-z)
12896 !      include 'DIMENSIONS'
12897 !      include 'COMMON.IOUNITS'
12898 !      include 'COMMON.VAR'
12899 !      include 'COMMON.CHAIN'
12900 !      include 'COMMON.GEO'
12901 !      include 'COMMON.LOCAL'
12902 !      include 'COMMON.DERIV'
12903       real(kind=8),dimension(6,nres) :: temp
12904       real(kind=8),dimension(3) :: xx,gg
12905       integer :: i,k,j,ii
12906       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
12907 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12908 !
12909 ! Check the gradient of the virtual-bond and SC vectors in the internal
12910 ! coordinates.
12911 !
12912       aincr=1.0d-6
12913       aincr2=5.0d-7
12914       call cartder
12915       write (iout,'(a)') '**************** dx/dalpha'
12916       write (iout,'(a)')
12917       do i=2,nres-1
12918       alphi=alph(i)
12919       alph(i)=alph(i)+aincr
12920       do k=1,3
12921         temp(k,i)=dc(k,nres+i)
12922         enddo
12923       call chainbuild
12924       do k=1,3
12925         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12926         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
12927         enddo
12928         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12929         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
12930         write (iout,'(a)')
12931       alph(i)=alphi
12932       call chainbuild
12933       enddo
12934       write (iout,'(a)')
12935       write (iout,'(a)') '**************** dx/domega'
12936       write (iout,'(a)')
12937       do i=2,nres-1
12938       omegi=omeg(i)
12939       omeg(i)=omeg(i)+aincr
12940       do k=1,3
12941         temp(k,i)=dc(k,nres+i)
12942         enddo
12943       call chainbuild
12944       do k=1,3
12945           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12946           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
12947                 (aincr*dabs(dxds(k+3,i))+aincr))
12948         enddo
12949         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12950             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
12951         write (iout,'(a)')
12952       omeg(i)=omegi
12953       call chainbuild
12954       enddo
12955       write (iout,'(a)')
12956       write (iout,'(a)') '**************** dx/dtheta'
12957       write (iout,'(a)')
12958       do i=3,nres
12959       theti=theta(i)
12960         theta(i)=theta(i)+aincr
12961         do j=i-1,nres-1
12962           do k=1,3
12963             temp(k,j)=dc(k,nres+j)
12964           enddo
12965         enddo
12966         call chainbuild
12967         do j=i-1,nres-1
12968         ii = indmat(i-2,j)
12969 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
12970         do k=1,3
12971           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12972           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
12973                   (aincr*dabs(dxdv(k,ii))+aincr))
12974           enddo
12975           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12976               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
12977           write(iout,'(a)')
12978         enddo
12979         write (iout,'(a)')
12980         theta(i)=theti
12981         call chainbuild
12982       enddo
12983       write (iout,'(a)') '***************** dx/dphi'
12984       write (iout,'(a)')
12985       do i=4,nres
12986         phi(i)=phi(i)+aincr
12987         do j=i-1,nres-1
12988           do k=1,3
12989             temp(k,j)=dc(k,nres+j)
12990           enddo
12991         enddo
12992         call chainbuild
12993         do j=i-1,nres-1
12994         ii = indmat(i-2,j)
12995 !         print *,'ii=',ii
12996         do k=1,3
12997           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12998             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
12999                   (aincr*dabs(dxdv(k+3,ii))+aincr))
13000           enddo
13001           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
13002               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
13003           write(iout,'(a)')
13004         enddo
13005         phi(i)=phi(i)-aincr
13006         call chainbuild
13007       enddo
13008       write (iout,'(a)') '****************** ddc/dtheta'
13009       do i=1,nres-2
13010         thet=theta(i+2)
13011         theta(i+2)=thet+aincr
13012         do j=i,nres
13013           do k=1,3
13014             temp(k,j)=dc(k,j)
13015           enddo
13016         enddo
13017         call chainbuild
13018         do j=i+1,nres-1
13019         ii = indmat(i,j)
13020 !         print *,'ii=',ii
13021         do k=1,3
13022           gg(k)=(dc(k,j)-temp(k,j))/aincr
13023           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
13024                  (aincr*dabs(dcdv(k,ii))+aincr))
13025           enddo
13026           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
13027                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
13028         write (iout,'(a)')
13029         enddo
13030         do j=1,nres
13031           do k=1,3
13032             dc(k,j)=temp(k,j)
13033           enddo
13034         enddo
13035         theta(i+2)=thet
13036       enddo
13037       write (iout,'(a)') '******************* ddc/dphi'
13038       do i=1,nres-3
13039         phii=phi(i+3)
13040         phi(i+3)=phii+aincr
13041         do j=1,nres
13042           do k=1,3
13043             temp(k,j)=dc(k,j)
13044           enddo
13045         enddo
13046         call chainbuild
13047         do j=i+2,nres-1
13048         ii = indmat(i+1,j)
13049 !         print *,'ii=',ii
13050         do k=1,3
13051           gg(k)=(dc(k,j)-temp(k,j))/aincr
13052             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
13053                  (aincr*dabs(dcdv(k+3,ii))+aincr))
13054           enddo
13055           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
13056                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
13057         write (iout,'(a)')
13058         enddo
13059         do j=1,nres
13060           do k=1,3
13061             dc(k,j)=temp(k,j)
13062           enddo
13063         enddo
13064         phi(i+3)=phii
13065       enddo
13066       return
13067       end subroutine check_cartgrad
13068 !-----------------------------------------------------------------------------
13069       subroutine check_ecart
13070 ! Check the gradient of the energy in Cartesian coordinates.
13071 !     implicit real*8 (a-h,o-z)
13072 !     include 'DIMENSIONS'
13073 !     include 'COMMON.CHAIN'
13074 !     include 'COMMON.DERIV'
13075 !     include 'COMMON.IOUNITS'
13076 !     include 'COMMON.VAR'
13077 !     include 'COMMON.CONTACTS'
13078       use comm_srutu
13079 !el      integer :: icall
13080 !el      common /srutu/ icall
13081       real(kind=8),dimension(6) :: ggg
13082       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
13083       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13084       real(kind=8),dimension(6,nres) :: grad_s
13085       real(kind=8),dimension(0:n_ene) :: energia,energia1
13086       integer :: uiparm(1)
13087       real(kind=8) :: urparm(1)
13088 !EL      external fdum
13089       integer :: nf,i,j,k
13090       real(kind=8) :: aincr,etot,etot1
13091       icg=1
13092       nf=0
13093       nfl=0
13094       call zerograd
13095       aincr=1.0D-5
13096       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
13097       nf=0
13098       icall=0
13099       call geom_to_var(nvar,x)
13100       call etotal(energia)
13101       etot=energia(0)
13102 !el      call enerprint(energia)
13103       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
13104       icall =1
13105       do i=1,nres
13106         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
13107       enddo
13108       do i=1,nres
13109       do j=1,3
13110         grad_s(j,i)=gradc(j,i,icg)
13111         grad_s(j+3,i)=gradx(j,i,icg)
13112         enddo
13113       enddo
13114       call flush(iout)
13115       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
13116       do i=1,nres
13117         do j=1,3
13118         xx(j)=c(j,i+nres)
13119         ddc(j)=dc(j,i)
13120         ddx(j)=dc(j,i+nres)
13121         enddo
13122       do j=1,3
13123         dc(j,i)=dc(j,i)+aincr
13124         do k=i+1,nres
13125           c(j,k)=c(j,k)+aincr
13126           c(j,k+nres)=c(j,k+nres)+aincr
13127           enddo
13128           call zerograd
13129           call etotal(energia1)
13130           etot1=energia1(0)
13131         ggg(j)=(etot1-etot)/aincr
13132         dc(j,i)=ddc(j)
13133         do k=i+1,nres
13134           c(j,k)=c(j,k)-aincr
13135           c(j,k+nres)=c(j,k+nres)-aincr
13136           enddo
13137         enddo
13138       do j=1,3
13139         c(j,i+nres)=c(j,i+nres)+aincr
13140         dc(j,i+nres)=dc(j,i+nres)+aincr
13141           call zerograd
13142           call etotal(energia1)
13143           etot1=energia1(0)
13144         ggg(j+3)=(etot1-etot)/aincr
13145         c(j,i+nres)=xx(j)
13146         dc(j,i+nres)=ddx(j)
13147         enddo
13148       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
13149          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
13150       enddo
13151       return
13152       end subroutine check_ecart
13153 #ifdef CARGRAD
13154 !-----------------------------------------------------------------------------
13155       subroutine check_ecartint
13156 ! Check the gradient of the energy in Cartesian coordinates.
13157       use io_base, only: intout
13158       use MD_data, only: iset
13159 !      implicit real*8 (a-h,o-z)
13160 !      include 'DIMENSIONS'
13161 !      include 'COMMON.CONTROL'
13162 !      include 'COMMON.CHAIN'
13163 !      include 'COMMON.DERIV'
13164 !      include 'COMMON.IOUNITS'
13165 !      include 'COMMON.VAR'
13166 !      include 'COMMON.CONTACTS'
13167 !      include 'COMMON.MD'
13168 !      include 'COMMON.LOCAL'
13169 !      include 'COMMON.SPLITELE'
13170       use comm_srutu
13171 !el      integer :: icall
13172 !el      common /srutu/ icall
13173       real(kind=8),dimension(6) :: ggg,ggg1
13174       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
13175       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13176       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
13177       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
13178       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
13179       real(kind=8),dimension(0:n_ene) :: energia,energia1
13180       integer :: uiparm(1)
13181       real(kind=8) :: urparm(1)
13182 !EL      external fdum
13183       integer :: i,j,k,nf
13184       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
13185                    etot21,etot22
13186       r_cut=2.0d0
13187       rlambd=0.3d0
13188       icg=1
13189       nf=0
13190       nfl=0
13191       if (iset.eq.0) iset=1
13192       call intout
13193 !      call intcartderiv
13194 !      call checkintcartgrad
13195       call zerograd
13196       aincr=1.0D-5
13197       write(iout,*) 'Calling CHECK_ECARTINT.'
13198       nf=0
13199       icall=0
13200       call geom_to_var(nvar,x)
13201       write (iout,*) "split_ene ",split_ene
13202       call flush(iout)
13203       if (.not.split_ene) then
13204         call zerograd
13205         call etotal(energia)
13206         etot=energia(0)
13207         call cartgrad
13208         icall =1
13209         do i=1,nres
13210           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
13211         enddo
13212         do j=1,3
13213           grad_s(j,0)=gcart(j,0)
13214         enddo
13215         do i=1,nres
13216           do j=1,3
13217             grad_s(j,i)=gcart(j,i)
13218             grad_s(j+3,i)=gxcart(j,i)
13219         write(iout,*) "before movement analytical gradient"
13220         do i=1,nres
13221           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13222           (gxcart(j,i),j=1,3)
13223         enddo
13224
13225           enddo
13226         enddo
13227       else
13228 !- split gradient check
13229         call zerograd
13230         call etotal_long(energia)
13231 !el        call enerprint(energia)
13232         call cartgrad
13233         icall =1
13234         do i=1,nres
13235           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13236           (gxcart(j,i),j=1,3)
13237         enddo
13238         do j=1,3
13239           grad_s(j,0)=gcart(j,0)
13240         enddo
13241         do i=1,nres
13242           do j=1,3
13243             grad_s(j,i)=gcart(j,i)
13244             grad_s(j+3,i)=gxcart(j,i)
13245           enddo
13246         enddo
13247         call zerograd
13248         call etotal_short(energia)
13249         call enerprint(energia)
13250         call cartgrad
13251         icall =1
13252         do i=1,nres
13253           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13254           (gxcart(j,i),j=1,3)
13255         enddo
13256         do j=1,3
13257           grad_s1(j,0)=gcart(j,0)
13258         enddo
13259         do i=1,nres
13260           do j=1,3
13261             grad_s1(j,i)=gcart(j,i)
13262             grad_s1(j+3,i)=gxcart(j,i)
13263           enddo
13264         enddo
13265       endif
13266       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
13267 !      do i=1,nres
13268       do i=nnt,nct
13269         do j=1,3
13270           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
13271           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
13272         ddc(j)=c(j,i)
13273         ddx(j)=c(j,i+nres)
13274           dcnorm_safe1(j)=dc_norm(j,i-1)
13275           dcnorm_safe2(j)=dc_norm(j,i)
13276           dxnorm_safe(j)=dc_norm(j,i+nres)
13277         enddo
13278       do j=1,3
13279         c(j,i)=ddc(j)+aincr
13280           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
13281           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
13282           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
13283           dc(j,i)=c(j,i+1)-c(j,i)
13284           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13285           call int_from_cart1(.false.)
13286           if (.not.split_ene) then
13287            call zerograd
13288             call etotal(energia1)
13289             etot1=energia1(0)
13290             write (iout,*) "ij",i,j," etot1",etot1
13291           else
13292 !- split gradient
13293             call etotal_long(energia1)
13294             etot11=energia1(0)
13295             call etotal_short(energia1)
13296             etot12=energia1(0)
13297           endif
13298 !- end split gradient
13299 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13300         c(j,i)=ddc(j)-aincr
13301           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
13302           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
13303           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
13304           dc(j,i)=c(j,i+1)-c(j,i)
13305           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13306           call int_from_cart1(.false.)
13307           if (.not.split_ene) then
13308             call zerograd
13309             call etotal(energia1)
13310             etot2=energia1(0)
13311             write (iout,*) "ij",i,j," etot2",etot2
13312           ggg(j)=(etot1-etot2)/(2*aincr)
13313           else
13314 !- split gradient
13315             call etotal_long(energia1)
13316             etot21=energia1(0)
13317           ggg(j)=(etot11-etot21)/(2*aincr)
13318             call etotal_short(energia1)
13319             etot22=energia1(0)
13320           ggg1(j)=(etot12-etot22)/(2*aincr)
13321 !- end split gradient
13322 !            write (iout,*) "etot21",etot21," etot22",etot22
13323           endif
13324 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13325         c(j,i)=ddc(j)
13326           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
13327           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
13328           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
13329           dc(j,i)=c(j,i+1)-c(j,i)
13330           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13331           dc_norm(j,i-1)=dcnorm_safe1(j)
13332           dc_norm(j,i)=dcnorm_safe2(j)
13333           dc_norm(j,i+nres)=dxnorm_safe(j)
13334         enddo
13335       do j=1,3
13336         c(j,i+nres)=ddx(j)+aincr
13337           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13338           call int_from_cart1(.false.)
13339           if (.not.split_ene) then
13340             call zerograd
13341             call etotal(energia1)
13342             etot1=energia1(0)
13343           else
13344 !- split gradient
13345             call etotal_long(energia1)
13346             etot11=energia1(0)
13347             call etotal_short(energia1)
13348             etot12=energia1(0)
13349           endif
13350 !- end split gradient
13351         c(j,i+nres)=ddx(j)-aincr
13352           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13353           call int_from_cart1(.false.)
13354           if (.not.split_ene) then
13355            call zerograd
13356            call etotal(energia1)
13357             etot2=energia1(0)
13358           ggg(j+3)=(etot1-etot2)/(2*aincr)
13359           else
13360 !- split gradient
13361             call etotal_long(energia1)
13362             etot21=energia1(0)
13363           ggg(j+3)=(etot11-etot21)/(2*aincr)
13364             call etotal_short(energia1)
13365             etot22=energia1(0)
13366           ggg1(j+3)=(etot12-etot22)/(2*aincr)
13367 !- end split gradient
13368           endif
13369 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13370         c(j,i+nres)=ddx(j)
13371           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13372           dc_norm(j,i+nres)=dxnorm_safe(j)
13373           call int_from_cart1(.false.)
13374         enddo
13375       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13376          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
13377         if (split_ene) then
13378           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13379          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
13380          k=1,6)
13381          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13382          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
13383          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
13384         endif
13385       enddo
13386       return
13387       end subroutine check_ecartint
13388 #else
13389 !-----------------------------------------------------------------------------
13390       subroutine check_ecartint
13391 ! Check the gradient of the energy in Cartesian coordinates.
13392       use io_base, only: intout
13393       use MD_data, only: iset
13394 !      implicit real*8 (a-h,o-z)
13395 !      include 'DIMENSIONS'
13396 !      include 'COMMON.CONTROL'
13397 !      include 'COMMON.CHAIN'
13398 !      include 'COMMON.DERIV'
13399 !      include 'COMMON.IOUNITS'
13400 !      include 'COMMON.VAR'
13401 !      include 'COMMON.CONTACTS'
13402 !      include 'COMMON.MD'
13403 !      include 'COMMON.LOCAL'
13404 !      include 'COMMON.SPLITELE'
13405       use comm_srutu
13406 !el      integer :: icall
13407 !el      common /srutu/ icall
13408       real(kind=8),dimension(6) :: ggg,ggg1
13409       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
13410       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13411       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
13412       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
13413       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
13414       real(kind=8),dimension(0:n_ene) :: energia,energia1
13415       integer :: uiparm(1)
13416       real(kind=8) :: urparm(1)
13417 !EL      external fdum
13418       integer :: i,j,k,nf
13419       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
13420                    etot21,etot22
13421       r_cut=2.0d0
13422       rlambd=0.3d0
13423       icg=1
13424       nf=0
13425       nfl=0
13426       if (iset.eq.0) iset=1
13427       call intout
13428 !      call intcartderiv
13429 !      call checkintcartgrad
13430       call zerograd
13431       aincr=1.0D-6
13432       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
13433       nf=0
13434       icall=0
13435       call geom_to_var(nvar,x)
13436       if (.not.split_ene) then
13437         call etotal(energia)
13438         etot=energia(0)
13439 !el        call enerprint(energia)
13440         call cartgrad
13441         icall =1
13442         do i=1,nres
13443           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
13444         enddo
13445         do j=1,3
13446           grad_s(j,0)=gcart(j,0)
13447           grad_s(j+3,0)=gxcart(j,0)
13448         enddo
13449         do i=1,nres
13450           do j=1,3
13451             grad_s(j,i)=gcart(j,i)
13452             grad_s(j+3,i)=gxcart(j,i)
13453           enddo
13454         enddo
13455         write(iout,*) "before movement analytical gradient"
13456         do i=1,nres
13457           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13458           (gxcart(j,i),j=1,3)
13459         enddo
13460
13461       else
13462 !- split gradient check
13463         call zerograd
13464         call etotal_long(energia)
13465 !el        call enerprint(energia)
13466         call cartgrad
13467         icall =1
13468         do i=1,nres
13469           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13470           (gxcart(j,i),j=1,3)
13471         enddo
13472         do j=1,3
13473           grad_s(j,0)=gcart(j,0)
13474         enddo
13475         do i=1,nres
13476           do j=1,3
13477             grad_s(j,i)=gcart(j,i)
13478 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
13479             grad_s(j+3,i)=gxcart(j,i)
13480           enddo
13481         enddo
13482         call zerograd
13483         call etotal_short(energia)
13484 !el        call enerprint(energia)
13485         call cartgrad
13486         icall =1
13487         do i=1,nres
13488           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13489           (gxcart(j,i),j=1,3)
13490         enddo
13491         do j=1,3
13492           grad_s1(j,0)=gcart(j,0)
13493         enddo
13494         do i=1,nres
13495           do j=1,3
13496             grad_s1(j,i)=gcart(j,i)
13497             grad_s1(j+3,i)=gxcart(j,i)
13498           enddo
13499         enddo
13500       endif
13501       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
13502       do i=0,nres
13503         do j=1,3
13504         xx(j)=c(j,i+nres)
13505         ddc(j)=dc(j,i)
13506         ddx(j)=dc(j,i+nres)
13507           do k=1,3
13508             dcnorm_safe(k)=dc_norm(k,i)
13509             dxnorm_safe(k)=dc_norm(k,i+nres)
13510           enddo
13511         enddo
13512       do j=1,3
13513         dc(j,i)=ddc(j)+aincr
13514           call chainbuild_cart
13515 #ifdef MPI
13516 ! Broadcast the order to compute internal coordinates to the slaves.
13517 !          if (nfgtasks.gt.1)
13518 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
13519 #endif
13520 !          call int_from_cart1(.false.)
13521           if (.not.split_ene) then
13522            call zerograd
13523             call etotal(energia1)
13524             etot1=energia1(0)
13525 !            call enerprint(energia1)
13526           else
13527 !- split gradient
13528             call etotal_long(energia1)
13529             etot11=energia1(0)
13530             call etotal_short(energia1)
13531             etot12=energia1(0)
13532 !            write (iout,*) "etot11",etot11," etot12",etot12
13533           endif
13534 !- end split gradient
13535 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13536         dc(j,i)=ddc(j)-aincr
13537           call chainbuild_cart
13538 !          call int_from_cart1(.false.)
13539           if (.not.split_ene) then
13540                   call zerograd
13541             call etotal(energia1)
13542             etot2=energia1(0)
13543           ggg(j)=(etot1-etot2)/(2*aincr)
13544           else
13545 !- split gradient
13546             call etotal_long(energia1)
13547             etot21=energia1(0)
13548           ggg(j)=(etot11-etot21)/(2*aincr)
13549             call etotal_short(energia1)
13550             etot22=energia1(0)
13551           ggg1(j)=(etot12-etot22)/(2*aincr)
13552 !- end split gradient
13553 !            write (iout,*) "etot21",etot21," etot22",etot22
13554           endif
13555 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13556         dc(j,i)=ddc(j)
13557           call chainbuild_cart
13558         enddo
13559       do j=1,3
13560         dc(j,i+nres)=ddx(j)+aincr
13561           call chainbuild_cart
13562 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
13563 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
13564 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
13565 !          write (iout,*) "dxnormnorm",dsqrt(
13566 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
13567 !          write (iout,*) "dxnormnormsafe",dsqrt(
13568 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
13569 !          write (iout,*)
13570           if (.not.split_ene) then
13571             call zerograd
13572             call etotal(energia1)
13573             etot1=energia1(0)
13574           else
13575 !- split gradient
13576             call etotal_long(energia1)
13577             etot11=energia1(0)
13578             call etotal_short(energia1)
13579             etot12=energia1(0)
13580           endif
13581 !- end split gradient
13582 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13583         dc(j,i+nres)=ddx(j)-aincr
13584           call chainbuild_cart
13585 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
13586 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
13587 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
13588 !          write (iout,*)
13589 !          write (iout,*) "dxnormnorm",dsqrt(
13590 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
13591 !          write (iout,*) "dxnormnormsafe",dsqrt(
13592 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
13593           if (.not.split_ene) then
13594             call zerograd
13595             call etotal(energia1)
13596             etot2=energia1(0)
13597           ggg(j+3)=(etot1-etot2)/(2*aincr)
13598           else
13599 !- split gradient
13600             call etotal_long(energia1)
13601             etot21=energia1(0)
13602           ggg(j+3)=(etot11-etot21)/(2*aincr)
13603             call etotal_short(energia1)
13604             etot22=energia1(0)
13605           ggg1(j+3)=(etot12-etot22)/(2*aincr)
13606 !- end split gradient
13607           endif
13608 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13609         dc(j,i+nres)=ddx(j)
13610           call chainbuild_cart
13611         enddo
13612       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13613          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
13614         if (split_ene) then
13615           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13616          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
13617          k=1,6)
13618          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13619          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
13620          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
13621         endif
13622       enddo
13623       return
13624       end subroutine check_ecartint
13625 #endif
13626 !-----------------------------------------------------------------------------
13627       subroutine check_eint
13628 ! Check the gradient of energy in internal coordinates.
13629 !      implicit real*8 (a-h,o-z)
13630 !      include 'DIMENSIONS'
13631 !      include 'COMMON.CHAIN'
13632 !      include 'COMMON.DERIV'
13633 !      include 'COMMON.IOUNITS'
13634 !      include 'COMMON.VAR'
13635 !      include 'COMMON.GEO'
13636       use comm_srutu
13637 !el      integer :: icall
13638 !el      common /srutu/ icall
13639       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
13640       integer :: uiparm(1)
13641       real(kind=8) :: urparm(1)
13642       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
13643       character(len=6) :: key
13644 !EL      external fdum
13645       integer :: i,ii,nf
13646       real(kind=8) :: xi,aincr,etot,etot1,etot2
13647       call zerograd
13648       aincr=1.0D-7
13649       print '(a)','Calling CHECK_INT.'
13650       nf=0
13651       nfl=0
13652       icg=1
13653       call geom_to_var(nvar,x)
13654       call var_to_geom(nvar,x)
13655       call chainbuild
13656       icall=1
13657 !      print *,'ICG=',ICG
13658       call etotal(energia)
13659       etot = energia(0)
13660 !el      call enerprint(energia)
13661 !      print *,'ICG=',ICG
13662 #ifdef MPL
13663       if (MyID.ne.BossID) then
13664         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
13665         nf=x(nvar+1)
13666         nfl=x(nvar+2)
13667         icg=x(nvar+3)
13668       endif
13669 #endif
13670       nf=1
13671       nfl=3
13672 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
13673       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
13674 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
13675       icall=1
13676       do i=1,nvar
13677         xi=x(i)
13678         x(i)=xi-0.5D0*aincr
13679         call var_to_geom(nvar,x)
13680         call chainbuild
13681         call etotal(energia1)
13682         etot1=energia1(0)
13683         x(i)=xi+0.5D0*aincr
13684         call var_to_geom(nvar,x)
13685         call chainbuild
13686         call etotal(energia2)
13687         etot2=energia2(0)
13688         gg(i)=(etot2-etot1)/aincr
13689         write (iout,*) i,etot1,etot2
13690         x(i)=xi
13691       enddo
13692       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
13693           '     RelDiff*100% '
13694       do i=1,nvar
13695         if (i.le.nphi) then
13696           ii=i
13697           key = ' phi'
13698         else if (i.le.nphi+ntheta) then
13699           ii=i-nphi
13700           key=' theta'
13701         else if (i.le.nphi+ntheta+nside) then
13702            ii=i-(nphi+ntheta)
13703            key=' alpha'
13704         else
13705            ii=i-(nphi+ntheta+nside)
13706            key=' omega'
13707         endif
13708         write (iout,'(i3,a,i3,3(1pd16.6))') &
13709        i,key,ii,gg(i),gana(i),&
13710        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
13711       enddo
13712       return
13713       end subroutine check_eint
13714 !-----------------------------------------------------------------------------
13715 ! econstr_local.F
13716 !-----------------------------------------------------------------------------
13717       subroutine Econstr_back
13718 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
13719 !      implicit real*8 (a-h,o-z)
13720 !      include 'DIMENSIONS'
13721 !      include 'COMMON.CONTROL'
13722 !      include 'COMMON.VAR'
13723 !      include 'COMMON.MD'
13724       use MD_data
13725 !#ifndef LANG0
13726 !      include 'COMMON.LANGEVIN'
13727 !#else
13728 !      include 'COMMON.LANGEVIN.lang0'
13729 !#endif
13730 !      include 'COMMON.CHAIN'
13731 !      include 'COMMON.DERIV'
13732 !      include 'COMMON.GEO'
13733 !      include 'COMMON.LOCAL'
13734 !      include 'COMMON.INTERACT'
13735 !      include 'COMMON.IOUNITS'
13736 !      include 'COMMON.NAMES'
13737 !      include 'COMMON.TIME1'
13738       integer :: i,j,ii,k
13739       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
13740
13741       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
13742       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
13743       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
13744
13745       Uconst_back=0.0d0
13746       do i=1,nres
13747         dutheta(i)=0.0d0
13748         dugamma(i)=0.0d0
13749         do j=1,3
13750           duscdiff(j,i)=0.0d0
13751           duscdiffx(j,i)=0.0d0
13752         enddo
13753       enddo
13754       do i=1,nfrag_back
13755         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
13756 !
13757 ! Deviations from theta angles
13758 !
13759         utheta_i=0.0d0
13760         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
13761           dtheta_i=theta(j)-thetaref(j)
13762           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
13763           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
13764         enddo
13765         utheta(i)=utheta_i/(ii-1)
13766 !
13767 ! Deviations from gamma angles
13768 !
13769         ugamma_i=0.0d0
13770         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
13771           dgamma_i=pinorm(phi(j)-phiref(j))
13772 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
13773           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
13774           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
13775 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
13776         enddo
13777         ugamma(i)=ugamma_i/(ii-2)
13778 !
13779 ! Deviations from local SC geometry
13780 !
13781         uscdiff(i)=0.0d0
13782         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
13783           dxx=xxtab(j)-xxref(j)
13784           dyy=yytab(j)-yyref(j)
13785           dzz=zztab(j)-zzref(j)
13786           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
13787           do k=1,3
13788             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
13789              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
13790              (ii-1)
13791             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
13792              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
13793              (ii-1)
13794             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
13795            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
13796             /(ii-1)
13797           enddo
13798 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
13799 !     &      xxref(j),yyref(j),zzref(j)
13800         enddo
13801         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
13802 !        write (iout,*) i," uscdiff",uscdiff(i)
13803 !
13804 ! Put together deviations from local geometry
13805 !
13806         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
13807           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
13808 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
13809 !     &   " uconst_back",uconst_back
13810         utheta(i)=dsqrt(utheta(i))
13811         ugamma(i)=dsqrt(ugamma(i))
13812         uscdiff(i)=dsqrt(uscdiff(i))
13813       enddo
13814       return
13815       end subroutine Econstr_back
13816 !-----------------------------------------------------------------------------
13817 ! energy_p_new-sep_barrier.F
13818 !-----------------------------------------------------------------------------
13819       real(kind=8) function sscale(r)
13820 !      include "COMMON.SPLITELE"
13821       real(kind=8) :: r,gamm
13822       if(r.lt.r_cut-rlamb) then
13823         sscale=1.0d0
13824       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13825         gamm=(r-(r_cut-rlamb))/rlamb
13826         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13827       else
13828         sscale=0d0
13829       endif
13830       return
13831       end function sscale
13832       real(kind=8) function sscale_grad(r)
13833 !      include "COMMON.SPLITELE"
13834       real(kind=8) :: r,gamm
13835       if(r.lt.r_cut-rlamb) then
13836         sscale_grad=0.0d0
13837       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13838         gamm=(r-(r_cut-rlamb))/rlamb
13839         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
13840       else
13841         sscale_grad=0d0
13842       endif
13843       return
13844       end function sscale_grad
13845
13846 !!!!!!!!!! PBCSCALE
13847       real(kind=8) function sscale_ele(r)
13848 !      include "COMMON.SPLITELE"
13849       real(kind=8) :: r,gamm
13850       if(r.lt.r_cut_ele-rlamb_ele) then
13851         sscale_ele=1.0d0
13852       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13853         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13854         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13855       else
13856         sscale_ele=0d0
13857       endif
13858       return
13859       end function sscale_ele
13860
13861       real(kind=8)  function sscagrad_ele(r)
13862       real(kind=8) :: r,gamm
13863 !      include "COMMON.SPLITELE"
13864       if(r.lt.r_cut_ele-rlamb_ele) then
13865         sscagrad_ele=0.0d0
13866       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13867         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13868         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
13869       else
13870         sscagrad_ele=0.0d0
13871       endif
13872       return
13873       end function sscagrad_ele
13874       real(kind=8) function sscalelip(r)
13875       real(kind=8) r,gamm
13876         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
13877       return
13878       end function sscalelip
13879 !C-----------------------------------------------------------------------
13880       real(kind=8) function sscagradlip(r)
13881       real(kind=8) r,gamm
13882         sscagradlip=r*(6.0d0*r-6.0d0)
13883       return
13884       end function sscagradlip
13885
13886 !!!!!!!!!!!!!!!
13887 !-----------------------------------------------------------------------------
13888       subroutine elj_long(evdw)
13889 !
13890 ! This subroutine calculates the interaction energy of nonbonded side chains
13891 ! assuming the LJ potential of interaction.
13892 !
13893 !      implicit real*8 (a-h,o-z)
13894 !      include 'DIMENSIONS'
13895 !      include 'COMMON.GEO'
13896 !      include 'COMMON.VAR'
13897 !      include 'COMMON.LOCAL'
13898 !      include 'COMMON.CHAIN'
13899 !      include 'COMMON.DERIV'
13900 !      include 'COMMON.INTERACT'
13901 !      include 'COMMON.TORSION'
13902 !      include 'COMMON.SBRIDGE'
13903 !      include 'COMMON.NAMES'
13904 !      include 'COMMON.IOUNITS'
13905 !      include 'COMMON.CONTACTS'
13906       real(kind=8),parameter :: accur=1.0d-10
13907       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13908 !el local variables
13909       integer :: i,iint,j,k,itypi,itypi1,itypj
13910       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13911       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
13912                       sslipj,ssgradlipj,aa,bb
13913 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13914       evdw=0.0D0
13915       do i=iatsc_s,iatsc_e
13916         itypi=itype(i,1)
13917         if (itypi.eq.ntyp1) cycle
13918         itypi1=itype(i+1,1)
13919         xi=c(1,nres+i)
13920         yi=c(2,nres+i)
13921         zi=c(3,nres+i)
13922         call to_box(xi,yi,zi)
13923         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13924 !
13925 ! Calculate SC interaction energy.
13926 !
13927         do iint=1,nint_gr(i)
13928 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13929 !d   &                  'iend=',iend(i,iint)
13930           do j=istart(i,iint),iend(i,iint)
13931             itypj=itype(j,1)
13932             if (itypj.eq.ntyp1) cycle
13933             xj=c(1,nres+j)-xi
13934             yj=c(2,nres+j)-yi
13935             zj=c(3,nres+j)-zi
13936             call to_box(xj,yj,zj)
13937             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13938             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13939              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13940             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13941              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13942             xj=boxshift(xj-xi,boxxsize)
13943             yj=boxshift(yj-yi,boxysize)
13944             zj=boxshift(zj-zi,boxzsize)
13945             rij=xj*xj+yj*yj+zj*zj
13946             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13947             if (sss.lt.1.0d0) then
13948               rrij=1.0D0/rij
13949               eps0ij=eps(itypi,itypj)
13950               fac=rrij**expon2
13951               e1=fac*fac*aa_aq(itypi,itypj)
13952               e2=fac*bb_aq(itypi,itypj)
13953               evdwij=e1+e2
13954               evdw=evdw+(1.0d0-sss)*evdwij
13955 !
13956 ! Calculate the components of the gradient in DC and X
13957 !
13958               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
13959               gg(1)=xj*fac
13960               gg(2)=yj*fac
13961               gg(3)=zj*fac
13962               do k=1,3
13963                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13964                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13965                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13966                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13967               enddo
13968             endif
13969           enddo      ! j
13970         enddo        ! iint
13971       enddo          ! i
13972       do i=1,nct
13973         do j=1,3
13974           gvdwc(j,i)=expon*gvdwc(j,i)
13975           gvdwx(j,i)=expon*gvdwx(j,i)
13976         enddo
13977       enddo
13978 !******************************************************************************
13979 !
13980 !                              N O T E !!!
13981 !
13982 ! To save time, the factor of EXPON has been extracted from ALL components
13983 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13984 ! use!
13985 !
13986 !******************************************************************************
13987       return
13988       end subroutine elj_long
13989 !-----------------------------------------------------------------------------
13990       subroutine elj_short(evdw)
13991 !
13992 ! This subroutine calculates the interaction energy of nonbonded side chains
13993 ! assuming the LJ potential of interaction.
13994 !
13995 !      implicit real*8 (a-h,o-z)
13996 !      include 'DIMENSIONS'
13997 !      include 'COMMON.GEO'
13998 !      include 'COMMON.VAR'
13999 !      include 'COMMON.LOCAL'
14000 !      include 'COMMON.CHAIN'
14001 !      include 'COMMON.DERIV'
14002 !      include 'COMMON.INTERACT'
14003 !      include 'COMMON.TORSION'
14004 !      include 'COMMON.SBRIDGE'
14005 !      include 'COMMON.NAMES'
14006 !      include 'COMMON.IOUNITS'
14007 !      include 'COMMON.CONTACTS'
14008       real(kind=8),parameter :: accur=1.0d-10
14009       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
14010 !el local variables
14011       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
14012       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
14013       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
14014                       sslipj,ssgradlipj
14015 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
14016       evdw=0.0D0
14017       do i=iatsc_s,iatsc_e
14018         itypi=itype(i,1)
14019         if (itypi.eq.ntyp1) cycle
14020         itypi1=itype(i+1,1)
14021         xi=c(1,nres+i)
14022         yi=c(2,nres+i)
14023         zi=c(3,nres+i)
14024         call to_box(xi,yi,zi)
14025         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14026 ! Change 12/1/95
14027         num_conti=0
14028 !
14029 ! Calculate SC interaction energy.
14030 !
14031         do iint=1,nint_gr(i)
14032 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
14033 !d   &                  'iend=',iend(i,iint)
14034           do j=istart(i,iint),iend(i,iint)
14035             itypj=itype(j,1)
14036             if (itypj.eq.ntyp1) cycle
14037             xj=c(1,nres+j)-xi
14038             yj=c(2,nres+j)-yi
14039             zj=c(3,nres+j)-zi
14040 ! Change 12/1/95 to calculate four-body interactions
14041             rij=xj*xj+yj*yj+zj*zj
14042             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
14043             if (sss.gt.0.0d0) then
14044               rrij=1.0D0/rij
14045               eps0ij=eps(itypi,itypj)
14046               fac=rrij**expon2
14047               e1=fac*fac*aa_aq(itypi,itypj)
14048               e2=fac*bb_aq(itypi,itypj)
14049               evdwij=e1+e2
14050               evdw=evdw+sss*evdwij
14051 !
14052 ! Calculate the components of the gradient in DC and X
14053 !
14054               fac=-rrij*(e1+evdwij)*sss
14055               gg(1)=xj*fac
14056               gg(2)=yj*fac
14057               gg(3)=zj*fac
14058               do k=1,3
14059                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
14060                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
14061                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
14062                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
14063               enddo
14064             endif
14065           enddo      ! j
14066         enddo        ! iint
14067       enddo          ! i
14068       do i=1,nct
14069         do j=1,3
14070           gvdwc(j,i)=expon*gvdwc(j,i)
14071           gvdwx(j,i)=expon*gvdwx(j,i)
14072         enddo
14073       enddo
14074 !******************************************************************************
14075 !
14076 !                              N O T E !!!
14077 !
14078 ! To save time, the factor of EXPON has been extracted from ALL components
14079 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
14080 ! use!
14081 !
14082 !******************************************************************************
14083       return
14084       end subroutine elj_short
14085 !-----------------------------------------------------------------------------
14086       subroutine eljk_long(evdw)
14087 !
14088 ! This subroutine calculates the interaction energy of nonbonded side chains
14089 ! assuming the LJK potential of interaction.
14090 !
14091 !      implicit real*8 (a-h,o-z)
14092 !      include 'DIMENSIONS'
14093 !      include 'COMMON.GEO'
14094 !      include 'COMMON.VAR'
14095 !      include 'COMMON.LOCAL'
14096 !      include 'COMMON.CHAIN'
14097 !      include 'COMMON.DERIV'
14098 !      include 'COMMON.INTERACT'
14099 !      include 'COMMON.IOUNITS'
14100 !      include 'COMMON.NAMES'
14101       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
14102       logical :: scheck
14103 !el local variables
14104       integer :: i,iint,j,k,itypi,itypi1,itypj
14105       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
14106                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
14107 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
14108       evdw=0.0D0
14109       do i=iatsc_s,iatsc_e
14110         itypi=itype(i,1)
14111         if (itypi.eq.ntyp1) cycle
14112         itypi1=itype(i+1,1)
14113         xi=c(1,nres+i)
14114         yi=c(2,nres+i)
14115         zi=c(3,nres+i)
14116           call to_box(xi,yi,zi)
14117
14118 !
14119 ! Calculate SC interaction energy.
14120 !
14121         do iint=1,nint_gr(i)
14122           do j=istart(i,iint),iend(i,iint)
14123             itypj=itype(j,1)
14124             if (itypj.eq.ntyp1) cycle
14125             xj=c(1,nres+j)-xi
14126             yj=c(2,nres+j)-yi
14127             zj=c(3,nres+j)-zi
14128           call to_box(xj,yj,zj)
14129       xj=boxshift(xj-xi,boxxsize)
14130       yj=boxshift(yj-yi,boxysize)
14131       zj=boxshift(zj-zi,boxzsize)
14132
14133             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14134             fac_augm=rrij**expon
14135             e_augm=augm(itypi,itypj)*fac_augm
14136             r_inv_ij=dsqrt(rrij)
14137             rij=1.0D0/r_inv_ij
14138             sss=sscale(rij/sigma(itypi,itypj))
14139             if (sss.lt.1.0d0) then
14140               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
14141               fac=r_shift_inv**expon
14142               e1=fac*fac*aa_aq(itypi,itypj)
14143               e2=fac*bb_aq(itypi,itypj)
14144               evdwij=e_augm+e1+e2
14145 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
14146 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
14147 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
14148 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
14149 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
14150 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
14151 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
14152               evdw=evdw+(1.0d0-sss)*evdwij
14153 !
14154 ! Calculate the components of the gradient in DC and X
14155 !
14156               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
14157               fac=fac*(1.0d0-sss)
14158               gg(1)=xj*fac
14159               gg(2)=yj*fac
14160               gg(3)=zj*fac
14161               do k=1,3
14162                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
14163                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
14164                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
14165                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
14166               enddo
14167             endif
14168           enddo      ! j
14169         enddo        ! iint
14170       enddo          ! i
14171       do i=1,nct
14172         do j=1,3
14173           gvdwc(j,i)=expon*gvdwc(j,i)
14174           gvdwx(j,i)=expon*gvdwx(j,i)
14175         enddo
14176       enddo
14177       return
14178       end subroutine eljk_long
14179 !-----------------------------------------------------------------------------
14180       subroutine eljk_short(evdw)
14181 !
14182 ! This subroutine calculates the interaction energy of nonbonded side chains
14183 ! assuming the LJK potential of interaction.
14184 !
14185 !      implicit real*8 (a-h,o-z)
14186 !      include 'DIMENSIONS'
14187 !      include 'COMMON.GEO'
14188 !      include 'COMMON.VAR'
14189 !      include 'COMMON.LOCAL'
14190 !      include 'COMMON.CHAIN'
14191 !      include 'COMMON.DERIV'
14192 !      include 'COMMON.INTERACT'
14193 !      include 'COMMON.IOUNITS'
14194 !      include 'COMMON.NAMES'
14195       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
14196       logical :: scheck
14197 !el local variables
14198       integer :: i,iint,j,k,itypi,itypi1,itypj
14199       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
14200                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij,&
14201                    sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
14202 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
14203       evdw=0.0D0
14204       do i=iatsc_s,iatsc_e
14205         itypi=itype(i,1)
14206         if (itypi.eq.ntyp1) cycle
14207         itypi1=itype(i+1,1)
14208         xi=c(1,nres+i)
14209         yi=c(2,nres+i)
14210         zi=c(3,nres+i)
14211         call to_box(xi,yi,zi)
14212         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14213 !
14214 ! Calculate SC interaction energy.
14215 !
14216         do iint=1,nint_gr(i)
14217           do j=istart(i,iint),iend(i,iint)
14218             itypj=itype(j,1)
14219             if (itypj.eq.ntyp1) cycle
14220             xj=c(1,nres+j)-xi
14221             yj=c(2,nres+j)-yi
14222             zj=c(3,nres+j)-zi
14223             call to_box(xj,yj,zj)
14224             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14225             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14226              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14227             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14228              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14229             xj=boxshift(xj-xi,boxxsize)
14230             yj=boxshift(yj-yi,boxysize)
14231             zj=boxshift(zj-zi,boxzsize)
14232             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14233             fac_augm=rrij**expon
14234             e_augm=augm(itypi,itypj)*fac_augm
14235             r_inv_ij=dsqrt(rrij)
14236             rij=1.0D0/r_inv_ij
14237             sss=sscale(rij/sigma(itypi,itypj))
14238             if (sss.gt.0.0d0) then
14239               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
14240               fac=r_shift_inv**expon
14241               e1=fac*fac*aa_aq(itypi,itypj)
14242               e2=fac*bb_aq(itypi,itypj)
14243               evdwij=e_augm+e1+e2
14244 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
14245 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
14246 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
14247 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
14248 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
14249 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
14250 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
14251               evdw=evdw+sss*evdwij
14252 !
14253 ! Calculate the components of the gradient in DC and X
14254 !
14255               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
14256               fac=fac*sss
14257               gg(1)=xj*fac
14258               gg(2)=yj*fac
14259               gg(3)=zj*fac
14260               do k=1,3
14261                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
14262                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
14263                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
14264                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
14265               enddo
14266             endif
14267           enddo      ! j
14268         enddo        ! iint
14269       enddo          ! i
14270       do i=1,nct
14271         do j=1,3
14272           gvdwc(j,i)=expon*gvdwc(j,i)
14273           gvdwx(j,i)=expon*gvdwx(j,i)
14274         enddo
14275       enddo
14276       return
14277       end subroutine eljk_short
14278 !-----------------------------------------------------------------------------
14279        subroutine ebp_long(evdw)
14280 ! This subroutine calculates the interaction energy of nonbonded side chains
14281 ! assuming the Berne-Pechukas potential of interaction.
14282 !
14283        use calc_data
14284 !      implicit real*8 (a-h,o-z)
14285 !      include 'DIMENSIONS'
14286 !      include 'COMMON.GEO'
14287 !      include 'COMMON.VAR'
14288 !      include 'COMMON.LOCAL'
14289 !      include 'COMMON.CHAIN'
14290 !      include 'COMMON.DERIV'
14291 !      include 'COMMON.NAMES'
14292 !      include 'COMMON.INTERACT'
14293 !      include 'COMMON.IOUNITS'
14294 !      include 'COMMON.CALC'
14295        use comm_srutu
14296 !el      integer :: icall
14297 !el      common /srutu/ icall
14298 !     double precision rrsave(maxdim)
14299         logical :: lprn
14300 !el local variables
14301         integer :: iint,itypi,itypi1,itypj
14302         real(kind=8) :: rrij,xi,yi,zi,fac,sslipi,ssgradlipi,&
14303                         sslipj,ssgradlipj,aa,bb
14304         real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
14305         evdw=0.0D0
14306 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
14307         evdw=0.0D0
14308 !     if (icall.eq.0) then
14309 !       lprn=.true.
14310 !     else
14311       lprn=.false.
14312 !     endif
14313 !el      ind=0
14314       do i=iatsc_s,iatsc_e
14315       itypi=itype(i,1)
14316       if (itypi.eq.ntyp1) cycle
14317       itypi1=itype(i+1,1)
14318       xi=c(1,nres+i)
14319       yi=c(2,nres+i)
14320       zi=c(3,nres+i)
14321         call to_box(xi,yi,zi)
14322         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14323       dxi=dc_norm(1,nres+i)
14324       dyi=dc_norm(2,nres+i)
14325       dzi=dc_norm(3,nres+i)
14326 !        dsci_inv=dsc_inv(itypi)
14327       dsci_inv=vbld_inv(i+nres)
14328 !
14329 ! Calculate SC interaction energy.
14330 !
14331       do iint=1,nint_gr(i)
14332       do j=istart(i,iint),iend(i,iint)
14333 !el            ind=ind+1
14334       itypj=itype(j,1)
14335       if (itypj.eq.ntyp1) cycle
14336 !            dscj_inv=dsc_inv(itypj)
14337       dscj_inv=vbld_inv(j+nres)
14338 chi1=chi(itypi,itypj)
14339 chi2=chi(itypj,itypi)
14340 chi12=chi1*chi2
14341 chip1=chip(itypi)
14342       alf1=alp(itypi)
14343       alf2=alp(itypj)
14344       alf12=0.5D0*(alf1+alf2)
14345         xj=c(1,nres+j)-xi
14346         yj=c(2,nres+j)-yi
14347         zj=c(3,nres+j)-zi
14348             call to_box(xj,yj,zj)
14349             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14350             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14351              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14352             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14353              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14354             xj=boxshift(xj-xi,boxxsize)
14355             yj=boxshift(yj-yi,boxysize)
14356             zj=boxshift(zj-zi,boxzsize)
14357         dxj=dc_norm(1,nres+j)
14358         dyj=dc_norm(2,nres+j)
14359         dzj=dc_norm(3,nres+j)
14360         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14361         rij=dsqrt(rrij)
14362       sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14363
14364         if (sss.lt.1.0d0) then
14365
14366         ! Calculate the angle-dependent terms of energy & contributions to derivatives.
14367         call sc_angular
14368         ! Calculate whole angle-dependent part of epsilon and contributions
14369         ! to its derivatives
14370         fac=(rrij*sigsq)**expon2
14371         e1=fac*fac*aa_aq(itypi,itypj)
14372         e2=fac*bb_aq(itypi,itypj)
14373       evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14374         eps2der=evdwij*eps3rt
14375         eps3der=evdwij*eps2rt
14376         evdwij=evdwij*eps2rt*eps3rt
14377       evdw=evdw+evdwij*(1.0d0-sss)
14378         if (lprn) then
14379         sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14380       epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14381         !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
14382         !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14383         !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
14384         !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
14385         !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
14386         !d     &          evdwij
14387         endif
14388         ! Calculate gradient components.
14389         e1=e1*eps1*eps2rt**2*eps3rt**2
14390       fac=-expon*(e1+evdwij)
14391         sigder=fac/sigsq
14392         fac=rrij*fac
14393         ! Calculate radial part of the gradient
14394         gg(1)=xj*fac
14395         gg(2)=yj*fac
14396         gg(3)=zj*fac
14397         ! Calculate the angular part of the gradient and sum add the contributions
14398         ! to the appropriate components of the Cartesian gradient.
14399       call sc_grad_scale(1.0d0-sss)
14400         endif
14401         enddo      ! j
14402         enddo        ! iint
14403         enddo          ! i
14404         !     stop
14405         return
14406         end subroutine ebp_long
14407         !-----------------------------------------------------------------------------
14408       subroutine ebp_short(evdw)
14409         !
14410         ! This subroutine calculates the interaction energy of nonbonded side chains
14411         ! assuming the Berne-Pechukas potential of interaction.
14412         !
14413         use calc_data
14414 !      implicit real*8 (a-h,o-z)
14415         !      include 'DIMENSIONS'
14416         !      include 'COMMON.GEO'
14417         !      include 'COMMON.VAR'
14418         !      include 'COMMON.LOCAL'
14419         !      include 'COMMON.CHAIN'
14420         !      include 'COMMON.DERIV'
14421         !      include 'COMMON.NAMES'
14422         !      include 'COMMON.INTERACT'
14423         !      include 'COMMON.IOUNITS'
14424         !      include 'COMMON.CALC'
14425         use comm_srutu
14426         !el      integer :: icall
14427         !el      common /srutu/ icall
14428 !     double precision rrsave(maxdim)
14429         logical :: lprn
14430         !el local variables
14431         integer :: iint,itypi,itypi1,itypj
14432         real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
14433         real(kind=8) :: sss,e1,e2,evdw,aa,bb, &
14434         sslipi,ssgradlipi,sslipj,ssgradlipj
14435         evdw=0.0D0
14436         !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
14437         evdw=0.0D0
14438         !     if (icall.eq.0) then
14439         !       lprn=.true.
14440         !     else
14441         lprn=.false.
14442         !     endif
14443         !el      ind=0
14444         do i=iatsc_s,iatsc_e
14445       itypi=itype(i,1)
14446         if (itypi.eq.ntyp1) cycle
14447         itypi1=itype(i+1,1)
14448         xi=c(1,nres+i)
14449         yi=c(2,nres+i)
14450         zi=c(3,nres+i)
14451         call to_box(xi,yi,zi)
14452       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14453
14454         dxi=dc_norm(1,nres+i)
14455         dyi=dc_norm(2,nres+i)
14456         dzi=dc_norm(3,nres+i)
14457         !        dsci_inv=dsc_inv(itypi)
14458       dsci_inv=vbld_inv(i+nres)
14459         !
14460         ! Calculate SC interaction energy.
14461         !
14462         do iint=1,nint_gr(i)
14463       do j=istart(i,iint),iend(i,iint)
14464         !el            ind=ind+1
14465       itypj=itype(j,1)
14466         if (itypj.eq.ntyp1) cycle
14467         !            dscj_inv=dsc_inv(itypj)
14468         dscj_inv=vbld_inv(j+nres)
14469         chi1=chi(itypi,itypj)
14470       chi2=chi(itypj,itypi)
14471         chi12=chi1*chi2
14472         chip1=chip(itypi)
14473       chip2=chip(itypj)
14474         chip12=chip1*chip2
14475         alf1=alp(itypi)
14476         alf2=alp(itypj)
14477       alf12=0.5D0*(alf1+alf2)
14478         xj=c(1,nres+j)-xi
14479         yj=c(2,nres+j)-yi
14480         zj=c(3,nres+j)-zi
14481         call to_box(xj,yj,zj)
14482       call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14483         aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14484         +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14485         bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14486              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14487             xj=boxshift(xj-xi,boxxsize)
14488             yj=boxshift(yj-yi,boxysize)
14489             zj=boxshift(zj-zi,boxzsize)
14490             dxj=dc_norm(1,nres+j)
14491             dyj=dc_norm(2,nres+j)
14492             dzj=dc_norm(3,nres+j)
14493             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14494             rij=dsqrt(rrij)
14495             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14496
14497             if (sss.gt.0.0d0) then
14498
14499 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
14500               call sc_angular
14501 ! Calculate whole angle-dependent part of epsilon and contributions
14502 ! to its derivatives
14503               fac=(rrij*sigsq)**expon2
14504               e1=fac*fac*aa_aq(itypi,itypj)
14505               e2=fac*bb_aq(itypi,itypj)
14506               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14507               eps2der=evdwij*eps3rt
14508               eps3der=evdwij*eps2rt
14509               evdwij=evdwij*eps2rt*eps3rt
14510               evdw=evdw+evdwij*sss
14511               if (lprn) then
14512               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14513               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14514 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
14515 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14516 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
14517 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
14518 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
14519 !d     &          evdwij
14520               endif
14521 ! Calculate gradient components.
14522               e1=e1*eps1*eps2rt**2*eps3rt**2
14523               fac=-expon*(e1+evdwij)
14524               sigder=fac/sigsq
14525               fac=rrij*fac
14526 ! Calculate radial part of the gradient
14527               gg(1)=xj*fac
14528               gg(2)=yj*fac
14529               gg(3)=zj*fac
14530 ! Calculate the angular part of the gradient and sum add the contributions
14531 ! to the appropriate components of the Cartesian gradient.
14532               call sc_grad_scale(sss)
14533             endif
14534           enddo      ! j
14535         enddo        ! iint
14536       enddo          ! i
14537 !     stop
14538       return
14539       end subroutine ebp_short
14540 !-----------------------------------------------------------------------------
14541       subroutine egb_long(evdw)
14542 !
14543 ! This subroutine calculates the interaction energy of nonbonded side chains
14544 ! assuming the Gay-Berne potential of interaction.
14545 !
14546       use calc_data
14547 !      implicit real*8 (a-h,o-z)
14548 !      include 'DIMENSIONS'
14549 !      include 'COMMON.GEO'
14550 !      include 'COMMON.VAR'
14551 !      include 'COMMON.LOCAL'
14552 !      include 'COMMON.CHAIN'
14553 !      include 'COMMON.DERIV'
14554 !      include 'COMMON.NAMES'
14555 !      include 'COMMON.INTERACT'
14556 !      include 'COMMON.IOUNITS'
14557 !      include 'COMMON.CALC'
14558 !      include 'COMMON.CONTROL'
14559       logical :: lprn
14560 !el local variables
14561       integer :: iint,itypi,itypi1,itypj,subchap
14562       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
14563       real(kind=8) :: sss,e1,e2,evdw,sss_grad
14564       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14565                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14566                     ssgradlipi,ssgradlipj
14567
14568
14569       evdw=0.0D0
14570 !cccc      energy_dec=.false.
14571 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14572       evdw=0.0D0
14573       lprn=.false.
14574 !     if (icall.eq.0) lprn=.false.
14575 !el      ind=0
14576       do i=iatsc_s,iatsc_e
14577         itypi=itype(i,1)
14578         if (itypi.eq.ntyp1) cycle
14579         itypi1=itype(i+1,1)
14580         xi=c(1,nres+i)
14581         yi=c(2,nres+i)
14582         zi=c(3,nres+i)
14583         call to_box(xi,yi,zi)
14584         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14585         dxi=dc_norm(1,nres+i)
14586         dyi=dc_norm(2,nres+i)
14587         dzi=dc_norm(3,nres+i)
14588 !        dsci_inv=dsc_inv(itypi)
14589         dsci_inv=vbld_inv(i+nres)
14590 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
14591 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
14592 !
14593 ! Calculate SC interaction energy.
14594 !
14595         do iint=1,nint_gr(i)
14596           do j=istart(i,iint),iend(i,iint)
14597             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14598 !              call dyn_ssbond_ene(i,j,evdwij)
14599 !              evdw=evdw+evdwij
14600 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14601 !                              'evdw',i,j,evdwij,' ss'
14602 !              if (energy_dec) write (iout,*) &
14603 !                              'evdw',i,j,evdwij,' ss'
14604 !             do k=j+1,iend(i,iint)
14605 !C search over all next residues
14606 !              if (dyn_ss_mask(k)) then
14607 !C check if they are cysteins
14608 !C              write(iout,*) 'k=',k
14609
14610 !c              write(iout,*) "PRZED TRI", evdwij
14611 !               evdwij_przed_tri=evdwij
14612 !              call triple_ssbond_ene(i,j,k,evdwij)
14613 !c               if(evdwij_przed_tri.ne.evdwij) then
14614 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14615 !c               endif
14616
14617 !c              write(iout,*) "PO TRI", evdwij
14618 !C call the energy function that removes the artifical triple disulfide
14619 !C bond the soubroutine is located in ssMD.F
14620 !              evdw=evdw+evdwij
14621               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14622                             'evdw',i,j,evdwij,'tss'
14623 !              endif!dyn_ss_mask(k)
14624 !             enddo! k
14625
14626             ELSE
14627 !el            ind=ind+1
14628             itypj=itype(j,1)
14629             if (itypj.eq.ntyp1) cycle
14630 !            dscj_inv=dsc_inv(itypj)
14631             dscj_inv=vbld_inv(j+nres)
14632 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14633 !     &       1.0d0/vbld(j+nres)
14634 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14635             sig0ij=sigma(itypi,itypj)
14636             chi1=chi(itypi,itypj)
14637             chi2=chi(itypj,itypi)
14638             chi12=chi1*chi2
14639             chip1=chip(itypi)
14640             chip2=chip(itypj)
14641             chip12=chip1*chip2
14642             alf1=alp(itypi)
14643             alf2=alp(itypj)
14644             alf12=0.5D0*(alf1+alf2)
14645             xj=c(1,nres+j)
14646             yj=c(2,nres+j)
14647             zj=c(3,nres+j)
14648 ! Searching for nearest neighbour
14649             call to_box(xj,yj,zj)
14650             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14651             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14652              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14653             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14654              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14655             xj=boxshift(xj-xi,boxxsize)
14656             yj=boxshift(yj-yi,boxysize)
14657             zj=boxshift(zj-zi,boxzsize)
14658             dxj=dc_norm(1,nres+j)
14659             dyj=dc_norm(2,nres+j)
14660             dzj=dc_norm(3,nres+j)
14661             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14662             rij=dsqrt(rrij)
14663             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14664             sss_ele_cut=sscale_ele(1.0d0/(rij))
14665             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14666             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14667             if (sss_ele_cut.le.0.0) cycle
14668             if (sss.lt.1.0d0) then
14669
14670 ! Calculate angle-dependent terms of energy and contributions to their
14671 ! derivatives.
14672               call sc_angular
14673               sigsq=1.0D0/sigsq
14674               sig=sig0ij*dsqrt(sigsq)
14675               rij_shift=1.0D0/rij-sig+sig0ij
14676 ! for diagnostics; uncomment
14677 !              rij_shift=1.2*sig0ij
14678 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14679               if (rij_shift.le.0.0D0) then
14680                 evdw=1.0D20
14681 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14682 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14683 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14684                 return
14685               endif
14686               sigder=-sig*sigsq
14687 !---------------------------------------------------------------
14688               rij_shift=1.0D0/rij_shift
14689               fac=rij_shift**expon
14690               e1=fac*fac*aa
14691               e2=fac*bb
14692               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14693               eps2der=evdwij*eps3rt
14694               eps3der=evdwij*eps2rt
14695 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14696 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14697               evdwij=evdwij*eps2rt*eps3rt
14698               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
14699               if (lprn) then
14700               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14701               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14702               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14703                 restyp(itypi,1),i,restyp(itypj,1),j,&
14704                 epsi,sigm,chi1,chi2,chip1,chip2,&
14705                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14706                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14707                 evdwij
14708               endif
14709
14710               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14711                               'evdw',i,j,evdwij
14712 !              if (energy_dec) write (iout,*) &
14713 !                              'evdw',i,j,evdwij,"egb_long"
14714
14715 ! Calculate gradient components.
14716               e1=e1*eps1*eps2rt**2*eps3rt**2
14717               fac=-expon*(e1+evdwij)*rij_shift
14718               sigder=fac*sigder
14719               fac=rij*fac
14720               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14721               *rij-sss_grad/(1.0-sss)*rij  &
14722             /sigmaii(itypi,itypj))
14723 !              fac=0.0d0
14724 ! Calculate the radial part of the gradient
14725               gg(1)=xj*fac
14726               gg(2)=yj*fac
14727               gg(3)=zj*fac
14728 ! Calculate angular part of the gradient.
14729               call sc_grad_scale(1.0d0-sss)
14730             ENDIF    !mask_dyn_ss
14731             endif
14732           enddo      ! j
14733         enddo        ! iint
14734       enddo          ! i
14735 !      write (iout,*) "Number of loop steps in EGB:",ind
14736 !ccc      energy_dec=.false.
14737       return
14738       end subroutine egb_long
14739 !-----------------------------------------------------------------------------
14740       subroutine egb_short(evdw)
14741 !
14742 ! This subroutine calculates the interaction energy of nonbonded side chains
14743 ! assuming the Gay-Berne potential of interaction.
14744 !
14745       use calc_data
14746 !      implicit real*8 (a-h,o-z)
14747 !      include 'DIMENSIONS'
14748 !      include 'COMMON.GEO'
14749 !      include 'COMMON.VAR'
14750 !      include 'COMMON.LOCAL'
14751 !      include 'COMMON.CHAIN'
14752 !      include 'COMMON.DERIV'
14753 !      include 'COMMON.NAMES'
14754 !      include 'COMMON.INTERACT'
14755 !      include 'COMMON.IOUNITS'
14756 !      include 'COMMON.CALC'
14757 !      include 'COMMON.CONTROL'
14758       logical :: lprn
14759 !el local variables
14760       integer :: iint,itypi,itypi1,itypj,subchap
14761       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
14762       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
14763       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14764                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14765                     ssgradlipi,ssgradlipj
14766       evdw=0.0D0
14767 !cccc      energy_dec=.false.
14768 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14769       evdw=0.0D0
14770       lprn=.false.
14771 !     if (icall.eq.0) lprn=.false.
14772 !el      ind=0
14773       do i=iatsc_s,iatsc_e
14774         itypi=itype(i,1)
14775         if (itypi.eq.ntyp1) cycle
14776         itypi1=itype(i+1,1)
14777         xi=c(1,nres+i)
14778         yi=c(2,nres+i)
14779         zi=c(3,nres+i)
14780         call to_box(xi,yi,zi)
14781         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14782
14783         dxi=dc_norm(1,nres+i)
14784         dyi=dc_norm(2,nres+i)
14785         dzi=dc_norm(3,nres+i)
14786 !        dsci_inv=dsc_inv(itypi)
14787         dsci_inv=vbld_inv(i+nres)
14788
14789         dxi=dc_norm(1,nres+i)
14790         dyi=dc_norm(2,nres+i)
14791         dzi=dc_norm(3,nres+i)
14792 !        dsci_inv=dsc_inv(itypi)
14793         dsci_inv=vbld_inv(i+nres)
14794         do iint=1,nint_gr(i)
14795           do j=istart(i,iint),iend(i,iint)
14796             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14797               call dyn_ssbond_ene(i,j,evdwij)
14798               evdw=evdw+evdwij
14799               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14800                               'evdw',i,j,evdwij,' ss'
14801              do k=j+1,iend(i,iint)
14802 !C search over all next residues
14803               if (dyn_ss_mask(k)) then
14804 !C check if they are cysteins
14805 !C              write(iout,*) 'k=',k
14806
14807 !c              write(iout,*) "PRZED TRI", evdwij
14808 !               evdwij_przed_tri=evdwij
14809               call triple_ssbond_ene(i,j,k,evdwij)
14810 !c               if(evdwij_przed_tri.ne.evdwij) then
14811 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14812 !c               endif
14813
14814 !c              write(iout,*) "PO TRI", evdwij
14815 !C call the energy function that removes the artifical triple disulfide
14816 !C bond the soubroutine is located in ssMD.F
14817               evdw=evdw+evdwij
14818               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14819                             'evdw',i,j,evdwij,'tss'
14820               endif!dyn_ss_mask(k)
14821              enddo! k
14822             ELSE
14823
14824 !          typj=itype(j,1)
14825             if (itypj.eq.ntyp1) cycle
14826 !            dscj_inv=dsc_inv(itypj)
14827             dscj_inv=vbld_inv(j+nres)
14828             dscj_inv=dsc_inv(itypj)
14829 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14830 !     &       1.0d0/vbld(j+nres)
14831 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14832             sig0ij=sigma(itypi,itypj)
14833             chi1=chi(itypi,itypj)
14834             chi2=chi(itypj,itypi)
14835             chi12=chi1*chi2
14836             chip1=chip(itypi)
14837             chip2=chip(itypj)
14838             chip12=chip1*chip2
14839             alf1=alp(itypi)
14840             alf2=alp(itypj)
14841             alf12=0.5D0*(alf1+alf2)
14842 !            xj=c(1,nres+j)-xi
14843 !            yj=c(2,nres+j)-yi
14844 !            zj=c(3,nres+j)-zi
14845             xj=c(1,nres+j)
14846             yj=c(2,nres+j)
14847             zj=c(3,nres+j)
14848 ! Searching for nearest neighbour
14849             call to_box(xj,yj,zj)
14850             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14851             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14852              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14853             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14854              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14855             xj=boxshift(xj-xi,boxxsize)
14856             yj=boxshift(yj-yi,boxysize)
14857             zj=boxshift(zj-zi,boxzsize)
14858             dxj=dc_norm(1,nres+j)
14859             dyj=dc_norm(2,nres+j)
14860             dzj=dc_norm(3,nres+j)
14861             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14862             rij=dsqrt(rrij)
14863             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14864             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14865             sss_ele_cut=sscale_ele(1.0d0/(rij))
14866             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14867             if (sss_ele_cut.le.0.0) cycle
14868
14869             if (sss.gt.0.0d0) then
14870
14871 ! Calculate angle-dependent terms of energy and contributions to their
14872 ! derivatives.
14873               call sc_angular
14874               sigsq=1.0D0/sigsq
14875               sig=sig0ij*dsqrt(sigsq)
14876               rij_shift=1.0D0/rij-sig+sig0ij
14877 ! for diagnostics; uncomment
14878 !              rij_shift=1.2*sig0ij
14879 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14880               if (rij_shift.le.0.0D0) then
14881                 evdw=1.0D20
14882 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14883 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14884 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14885                 return
14886               endif
14887               sigder=-sig*sigsq
14888 !---------------------------------------------------------------
14889               rij_shift=1.0D0/rij_shift
14890               fac=rij_shift**expon
14891               e1=fac*fac*aa
14892               e2=fac*bb
14893               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14894               eps2der=evdwij*eps3rt
14895               eps3der=evdwij*eps2rt
14896 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14897 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14898               evdwij=evdwij*eps2rt*eps3rt
14899               evdw=evdw+evdwij*sss*sss_ele_cut
14900               if (lprn) then
14901               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14902               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14903               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14904                 restyp(itypi,1),i,restyp(itypj,1),j,&
14905                 epsi,sigm,chi1,chi2,chip1,chip2,&
14906                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14907                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14908                 evdwij
14909               endif
14910
14911               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14912                               'evdw',i,j,evdwij
14913 !              if (energy_dec) write (iout,*) &
14914 !                              'evdw',i,j,evdwij,"egb_short"
14915
14916 ! Calculate gradient components.
14917               e1=e1*eps1*eps2rt**2*eps3rt**2
14918               fac=-expon*(e1+evdwij)*rij_shift
14919               sigder=fac*sigder
14920               fac=rij*fac
14921               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14922             *rij+sss_grad/sss*rij  &
14923             /sigmaii(itypi,itypj))
14924
14925 !              fac=0.0d0
14926 ! Calculate the radial part of the gradient
14927               gg(1)=xj*fac
14928               gg(2)=yj*fac
14929               gg(3)=zj*fac
14930 ! Calculate angular part of the gradient.
14931               call sc_grad_scale(sss)
14932             endif
14933           ENDIF !mask_dyn_ss
14934           enddo      ! j
14935         enddo        ! iint
14936       enddo          ! i
14937 !      write (iout,*) "Number of loop steps in EGB:",ind
14938 !ccc      energy_dec=.false.
14939       return
14940       end subroutine egb_short
14941 !-----------------------------------------------------------------------------
14942       subroutine egbv_long(evdw)
14943 !
14944 ! This subroutine calculates the interaction energy of nonbonded side chains
14945 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14946 !
14947       use calc_data
14948 !      implicit real*8 (a-h,o-z)
14949 !      include 'DIMENSIONS'
14950 !      include 'COMMON.GEO'
14951 !      include 'COMMON.VAR'
14952 !      include 'COMMON.LOCAL'
14953 !      include 'COMMON.CHAIN'
14954 !      include 'COMMON.DERIV'
14955 !      include 'COMMON.NAMES'
14956 !      include 'COMMON.INTERACT'
14957 !      include 'COMMON.IOUNITS'
14958 !      include 'COMMON.CALC'
14959       use comm_srutu
14960 !el      integer :: icall
14961 !el      common /srutu/ icall
14962       logical :: lprn
14963 !el local variables
14964       integer :: iint,itypi,itypi1,itypj
14965       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij,&
14966                       sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
14967       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
14968       evdw=0.0D0
14969 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14970       evdw=0.0D0
14971       lprn=.false.
14972 !     if (icall.eq.0) lprn=.true.
14973 !el      ind=0
14974       do i=iatsc_s,iatsc_e
14975         itypi=itype(i,1)
14976         if (itypi.eq.ntyp1) cycle
14977         itypi1=itype(i+1,1)
14978         xi=c(1,nres+i)
14979         yi=c(2,nres+i)
14980         zi=c(3,nres+i)
14981         call to_box(xi,yi,zi)
14982         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14983         dxi=dc_norm(1,nres+i)
14984         dyi=dc_norm(2,nres+i)
14985         dzi=dc_norm(3,nres+i)
14986
14987 !        dsci_inv=dsc_inv(itypi)
14988         dsci_inv=vbld_inv(i+nres)
14989 !
14990 ! Calculate SC interaction energy.
14991 !
14992         do iint=1,nint_gr(i)
14993           do j=istart(i,iint),iend(i,iint)
14994 !el            ind=ind+1
14995             itypj=itype(j,1)
14996             if (itypj.eq.ntyp1) cycle
14997 !            dscj_inv=dsc_inv(itypj)
14998             dscj_inv=vbld_inv(j+nres)
14999             sig0ij=sigma(itypi,itypj)
15000             r0ij=r0(itypi,itypj)
15001             chi1=chi(itypi,itypj)
15002             chi2=chi(itypj,itypi)
15003             chi12=chi1*chi2
15004             chip1=chip(itypi)
15005             chip2=chip(itypj)
15006             chip12=chip1*chip2
15007             alf1=alp(itypi)
15008             alf2=alp(itypj)
15009             alf12=0.5D0*(alf1+alf2)
15010             xj=c(1,nres+j)-xi
15011             yj=c(2,nres+j)-yi
15012             zj=c(3,nres+j)-zi
15013             call to_box(xj,yj,zj)
15014             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15015             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15016             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15017             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15018             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15019             xj=boxshift(xj-xi,boxxsize)
15020             yj=boxshift(yj-yi,boxysize)
15021             zj=boxshift(zj-zi,boxzsize)
15022             dxj=dc_norm(1,nres+j)
15023             dyj=dc_norm(2,nres+j)
15024             dzj=dc_norm(3,nres+j)
15025             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15026             rij=dsqrt(rrij)
15027
15028             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
15029
15030             if (sss.lt.1.0d0) then
15031
15032 ! Calculate angle-dependent terms of energy and contributions to their
15033 ! derivatives.
15034               call sc_angular
15035               sigsq=1.0D0/sigsq
15036               sig=sig0ij*dsqrt(sigsq)
15037               rij_shift=1.0D0/rij-sig+r0ij
15038 ! I hate to put IF's in the loops, but here don't have another choice!!!!
15039               if (rij_shift.le.0.0D0) then
15040                 evdw=1.0D20
15041                 return
15042               endif
15043               sigder=-sig*sigsq
15044 !---------------------------------------------------------------
15045               rij_shift=1.0D0/rij_shift
15046               fac=rij_shift**expon
15047               e1=fac*fac*aa_aq(itypi,itypj)
15048               e2=fac*bb_aq(itypi,itypj)
15049               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
15050               eps2der=evdwij*eps3rt
15051               eps3der=evdwij*eps2rt
15052               fac_augm=rrij**expon
15053               e_augm=augm(itypi,itypj)*fac_augm
15054               evdwij=evdwij*eps2rt*eps3rt
15055               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
15056               if (lprn) then
15057               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
15058               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
15059               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
15060                 restyp(itypi,1),i,restyp(itypj,1),j,&
15061                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
15062                 chi1,chi2,chip1,chip2,&
15063                 eps1,eps2rt**2,eps3rt**2,&
15064                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
15065                 evdwij+e_augm
15066               endif
15067 ! Calculate gradient components.
15068               e1=e1*eps1*eps2rt**2*eps3rt**2
15069               fac=-expon*(e1+evdwij)*rij_shift
15070               sigder=fac*sigder
15071               fac=rij*fac-2*expon*rrij*e_augm
15072 ! Calculate the radial part of the gradient
15073               gg(1)=xj*fac
15074               gg(2)=yj*fac
15075               gg(3)=zj*fac
15076 ! Calculate angular part of the gradient.
15077               call sc_grad_scale(1.0d0-sss)
15078             endif
15079           enddo      ! j
15080         enddo        ! iint
15081       enddo          ! i
15082       end subroutine egbv_long
15083 !-----------------------------------------------------------------------------
15084       subroutine egbv_short(evdw)
15085 !
15086 ! This subroutine calculates the interaction energy of nonbonded side chains
15087 ! assuming the Gay-Berne-Vorobjev potential of interaction.
15088 !
15089       use calc_data
15090 !      implicit real*8 (a-h,o-z)
15091 !      include 'DIMENSIONS'
15092 !      include 'COMMON.GEO'
15093 !      include 'COMMON.VAR'
15094 !      include 'COMMON.LOCAL'
15095 !      include 'COMMON.CHAIN'
15096 !      include 'COMMON.DERIV'
15097 !      include 'COMMON.NAMES'
15098 !      include 'COMMON.INTERACT'
15099 !      include 'COMMON.IOUNITS'
15100 !      include 'COMMON.CALC'
15101       use comm_srutu
15102 !el      integer :: icall
15103 !el      common /srutu/ icall
15104       logical :: lprn
15105 !el local variables
15106       integer :: iint,itypi,itypi1,itypj
15107       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift,&
15108                       sslipi,ssgradlipi, sslipj,ssgradlipj,aa,bb
15109       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
15110       evdw=0.0D0
15111 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
15112       evdw=0.0D0
15113       lprn=.false.
15114 !     if (icall.eq.0) lprn=.true.
15115 !el      ind=0
15116       do i=iatsc_s,iatsc_e
15117         itypi=itype(i,1)
15118         if (itypi.eq.ntyp1) cycle
15119         itypi1=itype(i+1,1)
15120         xi=c(1,nres+i)
15121         yi=c(2,nres+i)
15122         zi=c(3,nres+i)
15123         dxi=dc_norm(1,nres+i)
15124         dyi=dc_norm(2,nres+i)
15125         dzi=dc_norm(3,nres+i)
15126         call to_box(xi,yi,zi)
15127         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
15128 !        dsci_inv=dsc_inv(itypi)
15129         dsci_inv=vbld_inv(i+nres)
15130 !
15131 ! Calculate SC interaction energy.
15132 !
15133         do iint=1,nint_gr(i)
15134           do j=istart(i,iint),iend(i,iint)
15135 !el            ind=ind+1
15136             itypj=itype(j,1)
15137             if (itypj.eq.ntyp1) cycle
15138 !            dscj_inv=dsc_inv(itypj)
15139             dscj_inv=vbld_inv(j+nres)
15140             sig0ij=sigma(itypi,itypj)
15141             r0ij=r0(itypi,itypj)
15142             chi1=chi(itypi,itypj)
15143             chi2=chi(itypj,itypi)
15144             chi12=chi1*chi2
15145             chip1=chip(itypi)
15146             chip2=chip(itypj)
15147             chip12=chip1*chip2
15148             alf1=alp(itypi)
15149             alf2=alp(itypj)
15150             alf12=0.5D0*(alf1+alf2)
15151             xj=c(1,nres+j)-xi
15152             yj=c(2,nres+j)-yi
15153             zj=c(3,nres+j)-zi
15154             call to_box(xj,yj,zj)
15155             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15156             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15157             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15158             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15159             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15160             xj=boxshift(xj-xi,boxxsize)
15161             yj=boxshift(yj-yi,boxysize)
15162             zj=boxshift(zj-zi,boxzsize)
15163             dxj=dc_norm(1,nres+j)
15164             dyj=dc_norm(2,nres+j)
15165             dzj=dc_norm(3,nres+j)
15166             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15167             rij=dsqrt(rrij)
15168
15169             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
15170
15171             if (sss.gt.0.0d0) then
15172
15173 ! Calculate angle-dependent terms of energy and contributions to their
15174 ! derivatives.
15175               call sc_angular
15176               sigsq=1.0D0/sigsq
15177               sig=sig0ij*dsqrt(sigsq)
15178               rij_shift=1.0D0/rij-sig+r0ij
15179 ! I hate to put IF's in the loops, but here don't have another choice!!!!
15180               if (rij_shift.le.0.0D0) then
15181                 evdw=1.0D20
15182                 return
15183               endif
15184               sigder=-sig*sigsq
15185 !---------------------------------------------------------------
15186               rij_shift=1.0D0/rij_shift
15187               fac=rij_shift**expon
15188               e1=fac*fac*aa_aq(itypi,itypj)
15189               e2=fac*bb_aq(itypi,itypj)
15190               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
15191               eps2der=evdwij*eps3rt
15192               eps3der=evdwij*eps2rt
15193               fac_augm=rrij**expon
15194               e_augm=augm(itypi,itypj)*fac_augm
15195               evdwij=evdwij*eps2rt*eps3rt
15196               evdw=evdw+(evdwij+e_augm)*sss
15197               if (lprn) then
15198               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
15199               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
15200               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
15201                 restyp(itypi,1),i,restyp(itypj,1),j,&
15202                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
15203                 chi1,chi2,chip1,chip2,&
15204                 eps1,eps2rt**2,eps3rt**2,&
15205                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
15206                 evdwij+e_augm
15207               endif
15208 ! Calculate gradient components.
15209               e1=e1*eps1*eps2rt**2*eps3rt**2
15210               fac=-expon*(e1+evdwij)*rij_shift
15211               sigder=fac*sigder
15212               fac=rij*fac-2*expon*rrij*e_augm
15213 ! Calculate the radial part of the gradient
15214               gg(1)=xj*fac
15215               gg(2)=yj*fac
15216               gg(3)=zj*fac
15217 ! Calculate angular part of the gradient.
15218               call sc_grad_scale(sss)
15219             endif
15220           enddo      ! j
15221         enddo        ! iint
15222       enddo          ! i
15223       end subroutine egbv_short
15224 !-----------------------------------------------------------------------------
15225       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15226 !
15227 ! This subroutine calculates the average interaction energy and its gradient
15228 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
15229 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
15230 ! The potential depends both on the distance of peptide-group centers and on
15231 ! the orientation of the CA-CA virtual bonds.
15232 !
15233 !      implicit real*8 (a-h,o-z)
15234
15235       use comm_locel
15236 #ifdef MPI
15237       include 'mpif.h'
15238 #endif
15239 !      include 'DIMENSIONS'
15240 !      include 'COMMON.CONTROL'
15241 !      include 'COMMON.SETUP'
15242 !      include 'COMMON.IOUNITS'
15243 !      include 'COMMON.GEO'
15244 !      include 'COMMON.VAR'
15245 !      include 'COMMON.LOCAL'
15246 !      include 'COMMON.CHAIN'
15247 !      include 'COMMON.DERIV'
15248 !      include 'COMMON.INTERACT'
15249 !      include 'COMMON.CONTACTS'
15250 !      include 'COMMON.TORSION'
15251 !      include 'COMMON.VECTORS'
15252 !      include 'COMMON.FFIELD'
15253 !      include 'COMMON.TIME1'
15254       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
15255       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
15256       real(kind=8),dimension(2,2) :: acipa !el,a_temp
15257 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
15258       real(kind=8),dimension(4) :: muij
15259 !el      integer :: num_conti,j1,j2
15260 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
15261 !el                   dz_normi,xmedi,ymedi,zmedi
15262 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
15263 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15264 !el          num_conti,j1,j2
15265 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15266 #ifdef MOMENT
15267       real(kind=8) :: scal_el=1.0d0
15268 #else
15269       real(kind=8) :: scal_el=0.5d0
15270 #endif
15271 ! 12/13/98
15272 ! 13-go grudnia roku pamietnego...
15273       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
15274                                              0.0d0,1.0d0,0.0d0,&
15275                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
15276 !el local variables
15277       integer :: i,j,k
15278       real(kind=8) :: fac
15279       real(kind=8) :: dxj,dyj,dzj
15280       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
15281
15282 !      allocate(num_cont_hb(nres)) !(maxres)
15283 !d      write(iout,*) 'In EELEC'
15284 !d      do i=1,nloctyp
15285 !d        write(iout,*) 'Type',i
15286 !d        write(iout,*) 'B1',B1(:,i)
15287 !d        write(iout,*) 'B2',B2(:,i)
15288 !d        write(iout,*) 'CC',CC(:,:,i)
15289 !d        write(iout,*) 'DD',DD(:,:,i)
15290 !d        write(iout,*) 'EE',EE(:,:,i)
15291 !d      enddo
15292 !d      call check_vecgrad
15293 !d      stop
15294       if (icheckgrad.eq.1) then
15295         do i=1,nres-1
15296           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
15297           do k=1,3
15298             dc_norm(k,i)=dc(k,i)*fac
15299           enddo
15300 !          write (iout,*) 'i',i,' fac',fac
15301         enddo
15302       endif
15303       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15304           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
15305           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
15306 !        call vec_and_deriv
15307 #ifdef TIMING
15308         time01=MPI_Wtime()
15309 #endif
15310 !        print *, "before set matrices"
15311         call set_matrices
15312 !        print *,"after set martices"
15313 #ifdef TIMING
15314         time_mat=time_mat+MPI_Wtime()-time01
15315 #endif
15316       endif
15317 !d      do i=1,nres-1
15318 !d        write (iout,*) 'i=',i
15319 !d        do k=1,3
15320 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
15321 !d        enddo
15322 !d        do k=1,3
15323 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
15324 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
15325 !d        enddo
15326 !d      enddo
15327       t_eelecij=0.0d0
15328       ees=0.0D0
15329       evdw1=0.0D0
15330       eel_loc=0.0d0
15331       eello_turn3=0.0d0
15332       eello_turn4=0.0d0
15333 !el      ind=0
15334       do i=1,nres
15335         num_cont_hb(i)=0
15336       enddo
15337 !d      print '(a)','Enter EELEC'
15338 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
15339 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
15340 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
15341       do i=1,nres
15342         gel_loc_loc(i)=0.0d0
15343         gcorr_loc(i)=0.0d0
15344       enddo
15345 !
15346 !
15347 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
15348 !
15349 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
15350 !
15351       do i=iturn3_start,iturn3_end
15352         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
15353         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
15354         dxi=dc(1,i)
15355         dyi=dc(2,i)
15356         dzi=dc(3,i)
15357         dx_normi=dc_norm(1,i)
15358         dy_normi=dc_norm(2,i)
15359         dz_normi=dc_norm(3,i)
15360         xmedi=c(1,i)+0.5d0*dxi
15361         ymedi=c(2,i)+0.5d0*dyi
15362         zmedi=c(3,i)+0.5d0*dzi
15363         call to_box(xmedi,ymedi,zmedi)
15364         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15365         num_conti=0
15366         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
15367         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
15368         num_cont_hb(i)=num_conti
15369       enddo
15370       do i=iturn4_start,iturn4_end
15371         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
15372           .or. itype(i+3,1).eq.ntyp1 &
15373           .or. itype(i+4,1).eq.ntyp1) cycle
15374         dxi=dc(1,i)
15375         dyi=dc(2,i)
15376         dzi=dc(3,i)
15377         dx_normi=dc_norm(1,i)
15378         dy_normi=dc_norm(2,i)
15379         dz_normi=dc_norm(3,i)
15380         xmedi=c(1,i)+0.5d0*dxi
15381         ymedi=c(2,i)+0.5d0*dyi
15382         zmedi=c(3,i)+0.5d0*dzi
15383
15384         call to_box(xmedi,ymedi,zmedi)
15385         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15386
15387         num_conti=num_cont_hb(i)
15388         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
15389         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
15390           call eturn4(i,eello_turn4)
15391         num_cont_hb(i)=num_conti
15392       enddo   ! i
15393 !
15394 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
15395 !
15396       do i=iatel_s,iatel_e
15397         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15398         dxi=dc(1,i)
15399         dyi=dc(2,i)
15400         dzi=dc(3,i)
15401         dx_normi=dc_norm(1,i)
15402         dy_normi=dc_norm(2,i)
15403         dz_normi=dc_norm(3,i)
15404         xmedi=c(1,i)+0.5d0*dxi
15405         ymedi=c(2,i)+0.5d0*dyi
15406         zmedi=c(3,i)+0.5d0*dzi
15407         call to_box(xmedi,ymedi,zmedi)
15408         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15409 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
15410         num_conti=num_cont_hb(i)
15411         do j=ielstart(i),ielend(i)
15412           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15413           call eelecij_scale(i,j,ees,evdw1,eel_loc)
15414         enddo ! j
15415         num_cont_hb(i)=num_conti
15416       enddo   ! i
15417 !      write (iout,*) "Number of loop steps in EELEC:",ind
15418 !d      do i=1,nres
15419 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
15420 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
15421 !d      enddo
15422 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
15423 !cc      eel_loc=eel_loc+eello_turn3
15424 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
15425       return
15426       end subroutine eelec_scale
15427 !-----------------------------------------------------------------------------
15428       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
15429 !      implicit real*8 (a-h,o-z)
15430
15431       use comm_locel
15432 !      include 'DIMENSIONS'
15433 #ifdef MPI
15434       include "mpif.h"
15435 #endif
15436 !      include 'COMMON.CONTROL'
15437 !      include 'COMMON.IOUNITS'
15438 !      include 'COMMON.GEO'
15439 !      include 'COMMON.VAR'
15440 !      include 'COMMON.LOCAL'
15441 !      include 'COMMON.CHAIN'
15442 !      include 'COMMON.DERIV'
15443 !      include 'COMMON.INTERACT'
15444 !      include 'COMMON.CONTACTS'
15445 !      include 'COMMON.TORSION'
15446 !      include 'COMMON.VECTORS'
15447 !      include 'COMMON.FFIELD'
15448 !      include 'COMMON.TIME1'
15449       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
15450       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
15451       real(kind=8),dimension(2,2) :: acipa !el,a_temp
15452 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
15453       real(kind=8),dimension(4) :: muij
15454       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15455                     dist_temp, dist_init,sss_grad
15456       integer xshift,yshift,zshift
15457
15458 !el      integer :: num_conti,j1,j2
15459 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
15460 !el                   dz_normi,xmedi,ymedi,zmedi
15461 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
15462 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15463 !el          num_conti,j1,j2
15464 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15465 #ifdef MOMENT
15466       real(kind=8) :: scal_el=1.0d0
15467 #else
15468       real(kind=8) :: scal_el=0.5d0
15469 #endif
15470 ! 12/13/98
15471 ! 13-go grudnia roku pamietnego...
15472       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
15473                                              0.0d0,1.0d0,0.0d0,&
15474                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
15475 !el local variables
15476       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
15477       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
15478       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
15479       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
15480       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
15481       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
15482       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
15483                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
15484                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
15485                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
15486                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
15487                   ecosam,ecosbm,ecosgm,ghalf,time00,faclipij,faclipij2
15488 !      integer :: maxconts
15489 !      maxconts = nres/4
15490 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15491 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15492 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15493 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15494 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15495 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15496 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15497 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15498 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
15499 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
15500 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
15501 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
15502 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
15503
15504 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
15505 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
15506
15507 #ifdef MPI
15508           time00=MPI_Wtime()
15509 #endif
15510 !d      write (iout,*) "eelecij",i,j
15511 !el          ind=ind+1
15512           iteli=itel(i)
15513           itelj=itel(j)
15514           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15515           aaa=app(iteli,itelj)
15516           bbb=bpp(iteli,itelj)
15517           ael6i=ael6(iteli,itelj)
15518           ael3i=ael3(iteli,itelj)
15519           dxj=dc(1,j)
15520           dyj=dc(2,j)
15521           dzj=dc(3,j)
15522           dx_normj=dc_norm(1,j)
15523           dy_normj=dc_norm(2,j)
15524           dz_normj=dc_norm(3,j)
15525 !          xj=c(1,j)+0.5D0*dxj-xmedi
15526 !          yj=c(2,j)+0.5D0*dyj-ymedi
15527 !          zj=c(3,j)+0.5D0*dzj-zmedi
15528           xj=c(1,j)+0.5D0*dxj
15529           yj=c(2,j)+0.5D0*dyj
15530           zj=c(3,j)+0.5D0*dzj
15531           call to_box(xj,yj,zj)
15532           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15533           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
15534           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
15535           xj=boxshift(xj-xmedi,boxxsize)
15536           yj=boxshift(yj-ymedi,boxysize)
15537           zj=boxshift(zj-zmedi,boxzsize)
15538           rij=xj*xj+yj*yj+zj*zj
15539           rrmij=1.0D0/rij
15540           rij=dsqrt(rij)
15541           rmij=1.0D0/rij
15542 ! For extracting the short-range part of Evdwpp
15543           sss=sscale(rij/rpp(iteli,itelj))
15544             sss_ele_cut=sscale_ele(rij)
15545             sss_ele_grad=sscagrad_ele(rij)
15546             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15547 !             sss_ele_cut=1.0d0
15548 !             sss_ele_grad=0.0d0
15549             if (sss_ele_cut.le.0.0) go to 128
15550
15551           r3ij=rrmij*rmij
15552           r6ij=r3ij*r3ij
15553           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
15554           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
15555           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
15556           fac=cosa-3.0D0*cosb*cosg
15557           ev1=aaa*r6ij*r6ij
15558 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15559           if (j.eq.i+2) ev1=scal_el*ev1
15560           ev2=bbb*r6ij
15561           fac3=ael6i*r6ij
15562           fac4=ael3i*r3ij
15563           evdwij=ev1+ev2
15564           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
15565           el2=fac4*fac
15566           eesij=el1+el2
15567 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
15568           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
15569           ees=ees+eesij*sss_ele_cut
15570           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
15571 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
15572 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
15573 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
15574 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
15575
15576           if (energy_dec) then
15577               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15578               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
15579           endif
15580
15581 !
15582 ! Calculate contributions to the Cartesian gradient.
15583 !
15584 #ifdef SPLITELE
15585           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15586           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
15587           fac1=fac
15588           erij(1)=xj*rmij
15589           erij(2)=yj*rmij
15590           erij(3)=zj*rmij
15591 !
15592 ! Radial derivatives. First process both termini of the fragment (i,j)
15593 !
15594           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
15595           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
15596           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
15597 !          do k=1,3
15598 !            ghalf=0.5D0*ggg(k)
15599 !            gelc(k,i)=gelc(k,i)+ghalf
15600 !            gelc(k,j)=gelc(k,j)+ghalf
15601 !          enddo
15602 ! 9/28/08 AL Gradient compotents will be summed only at the end
15603           do k=1,3
15604             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15605             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15606           enddo
15607 !
15608 ! Loop over residues i+1 thru j-1.
15609 !
15610 !grad          do k=i+1,j-1
15611 !grad            do l=1,3
15612 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15613 !grad            enddo
15614 !grad          enddo
15615           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
15616           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15617           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
15618           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15619           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
15620           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15621 !          do k=1,3
15622 !            ghalf=0.5D0*ggg(k)
15623 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
15624 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
15625 !          enddo
15626 ! 9/28/08 AL Gradient compotents will be summed only at the end
15627           do k=1,3
15628             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15629             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15630           enddo
15631 !
15632 ! Loop over residues i+1 thru j-1.
15633 !
15634 !grad          do k=i+1,j-1
15635 !grad            do l=1,3
15636 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
15637 !grad            enddo
15638 !grad          enddo
15639 #else
15640           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15641           facel=(el1+eesij)*sss_ele_cut
15642           fac1=fac
15643           fac=-3*rrmij*(facvdw+facvdw+facel)
15644           erij(1)=xj*rmij
15645           erij(2)=yj*rmij
15646           erij(3)=zj*rmij
15647 !
15648 ! Radial derivatives. First process both termini of the fragment (i,j)
15649 !
15650           ggg(1)=fac*xj
15651           ggg(2)=fac*yj
15652           ggg(3)=fac*zj
15653 !          do k=1,3
15654 !            ghalf=0.5D0*ggg(k)
15655 !            gelc(k,i)=gelc(k,i)+ghalf
15656 !            gelc(k,j)=gelc(k,j)+ghalf
15657 !          enddo
15658 ! 9/28/08 AL Gradient compotents will be summed only at the end
15659           do k=1,3
15660             gelc_long(k,j)=gelc(k,j)+ggg(k)
15661             gelc_long(k,i)=gelc(k,i)-ggg(k)
15662           enddo
15663 !
15664 ! Loop over residues i+1 thru j-1.
15665 !
15666 !grad          do k=i+1,j-1
15667 !grad            do l=1,3
15668 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15669 !grad            enddo
15670 !grad          enddo
15671 ! 9/28/08 AL Gradient compotents will be summed only at the end
15672           ggg(1)=facvdw*xj
15673           ggg(2)=facvdw*yj
15674           ggg(3)=facvdw*zj
15675           do k=1,3
15676             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15677             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15678           enddo
15679 #endif
15680 !
15681 ! Angular part
15682 !
15683           ecosa=2.0D0*fac3*fac1+fac4
15684           fac4=-3.0D0*fac4
15685           fac3=-6.0D0*fac3
15686           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
15687           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
15688           do k=1,3
15689             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15690             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15691           enddo
15692 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
15693 !d   &          (dcosg(k),k=1,3)
15694           do k=1,3
15695             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
15696           enddo
15697 !          do k=1,3
15698 !            ghalf=0.5D0*ggg(k)
15699 !            gelc(k,i)=gelc(k,i)+ghalf
15700 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
15701 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15702 !            gelc(k,j)=gelc(k,j)+ghalf
15703 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
15704 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15705 !          enddo
15706 !grad          do k=i+1,j-1
15707 !grad            do l=1,3
15708 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15709 !grad            enddo
15710 !grad          enddo
15711           do k=1,3
15712             gelc(k,i)=gelc(k,i) &
15713                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15714                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
15715                      *sss_ele_cut
15716             gelc(k,j)=gelc(k,j) &
15717                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15718                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15719                      *sss_ele_cut
15720             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15721             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15722           enddo
15723           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15724               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
15725               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15726 !
15727 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
15728 !   energy of a peptide unit is assumed in the form of a second-order
15729 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
15730 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
15731 !   are computed for EVERY pair of non-contiguous peptide groups.
15732 !
15733           if (j.lt.nres-1) then
15734             j1=j+1
15735             j2=j-1
15736           else
15737             j1=j-1
15738             j2=j-2
15739           endif
15740           kkk=0
15741           do k=1,2
15742             do l=1,2
15743               kkk=kkk+1
15744               muij(kkk)=mu(k,i)*mu(l,j)
15745             enddo
15746           enddo
15747 !d         write (iout,*) 'EELEC: i',i,' j',j
15748 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
15749 !d          write(iout,*) 'muij',muij
15750           ury=scalar(uy(1,i),erij)
15751           urz=scalar(uz(1,i),erij)
15752           vry=scalar(uy(1,j),erij)
15753           vrz=scalar(uz(1,j),erij)
15754           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
15755           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
15756           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
15757           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
15758           fac=dsqrt(-ael6i)*r3ij
15759           a22=a22*fac
15760           a23=a23*fac
15761           a32=a32*fac
15762           a33=a33*fac
15763 !d          write (iout,'(4i5,4f10.5)')
15764 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
15765 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
15766 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
15767 !d     &      uy(:,j),uz(:,j)
15768 !d          write (iout,'(4f10.5)')
15769 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
15770 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
15771 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
15772 !d           write (iout,'(9f10.5/)')
15773 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
15774 ! Derivatives of the elements of A in virtual-bond vectors
15775           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
15776           do k=1,3
15777             uryg(k,1)=scalar(erder(1,k),uy(1,i))
15778             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
15779             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
15780             urzg(k,1)=scalar(erder(1,k),uz(1,i))
15781             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
15782             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
15783             vryg(k,1)=scalar(erder(1,k),uy(1,j))
15784             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
15785             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
15786             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
15787             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
15788             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
15789           enddo
15790 ! Compute radial contributions to the gradient
15791           facr=-3.0d0*rrmij
15792           a22der=a22*facr
15793           a23der=a23*facr
15794           a32der=a32*facr
15795           a33der=a33*facr
15796           agg(1,1)=a22der*xj
15797           agg(2,1)=a22der*yj
15798           agg(3,1)=a22der*zj
15799           agg(1,2)=a23der*xj
15800           agg(2,2)=a23der*yj
15801           agg(3,2)=a23der*zj
15802           agg(1,3)=a32der*xj
15803           agg(2,3)=a32der*yj
15804           agg(3,3)=a32der*zj
15805           agg(1,4)=a33der*xj
15806           agg(2,4)=a33der*yj
15807           agg(3,4)=a33der*zj
15808 ! Add the contributions coming from er
15809           fac3=-3.0d0*fac
15810           do k=1,3
15811             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
15812             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
15813             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
15814             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
15815           enddo
15816           do k=1,3
15817 ! Derivatives in DC(i)
15818 !grad            ghalf1=0.5d0*agg(k,1)
15819 !grad            ghalf2=0.5d0*agg(k,2)
15820 !grad            ghalf3=0.5d0*agg(k,3)
15821 !grad            ghalf4=0.5d0*agg(k,4)
15822             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
15823             -3.0d0*uryg(k,2)*vry)!+ghalf1
15824             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
15825             -3.0d0*uryg(k,2)*vrz)!+ghalf2
15826             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
15827             -3.0d0*urzg(k,2)*vry)!+ghalf3
15828             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
15829             -3.0d0*urzg(k,2)*vrz)!+ghalf4
15830 ! Derivatives in DC(i+1)
15831             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
15832             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
15833             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
15834             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
15835             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
15836             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
15837             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
15838             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
15839 ! Derivatives in DC(j)
15840             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
15841             -3.0d0*vryg(k,2)*ury)!+ghalf1
15842             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
15843             -3.0d0*vrzg(k,2)*ury)!+ghalf2
15844             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
15845             -3.0d0*vryg(k,2)*urz)!+ghalf3
15846             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
15847             -3.0d0*vrzg(k,2)*urz)!+ghalf4
15848 ! Derivatives in DC(j+1) or DC(nres-1)
15849             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
15850             -3.0d0*vryg(k,3)*ury)
15851             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
15852             -3.0d0*vrzg(k,3)*ury)
15853             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
15854             -3.0d0*vryg(k,3)*urz)
15855             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
15856             -3.0d0*vrzg(k,3)*urz)
15857 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
15858 !grad              do l=1,4
15859 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
15860 !grad              enddo
15861 !grad            endif
15862           enddo
15863           acipa(1,1)=a22
15864           acipa(1,2)=a23
15865           acipa(2,1)=a32
15866           acipa(2,2)=a33
15867           a22=-a22
15868           a23=-a23
15869           do l=1,2
15870             do k=1,3
15871               agg(k,l)=-agg(k,l)
15872               aggi(k,l)=-aggi(k,l)
15873               aggi1(k,l)=-aggi1(k,l)
15874               aggj(k,l)=-aggj(k,l)
15875               aggj1(k,l)=-aggj1(k,l)
15876             enddo
15877           enddo
15878           if (j.lt.nres-1) then
15879             a22=-a22
15880             a32=-a32
15881             do l=1,3,2
15882               do k=1,3
15883                 agg(k,l)=-agg(k,l)
15884                 aggi(k,l)=-aggi(k,l)
15885                 aggi1(k,l)=-aggi1(k,l)
15886                 aggj(k,l)=-aggj(k,l)
15887                 aggj1(k,l)=-aggj1(k,l)
15888               enddo
15889             enddo
15890           else
15891             a22=-a22
15892             a23=-a23
15893             a32=-a32
15894             a33=-a33
15895             do l=1,4
15896               do k=1,3
15897                 agg(k,l)=-agg(k,l)
15898                 aggi(k,l)=-aggi(k,l)
15899                 aggi1(k,l)=-aggi1(k,l)
15900                 aggj(k,l)=-aggj(k,l)
15901                 aggj1(k,l)=-aggj1(k,l)
15902               enddo
15903             enddo
15904           endif
15905           ENDIF ! WCORR
15906           IF (wel_loc.gt.0.0d0) THEN
15907 ! Contribution to the local-electrostatic energy coming from the i-j pair
15908           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
15909            +a33*muij(4)
15910 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
15911 !           print *,"EELLOC",i,gel_loc_loc(i-1)
15912           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15913                   'eelloc',i,j,eel_loc_ij
15914 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
15915
15916           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
15917 ! Partial derivatives in virtual-bond dihedral angles gamma
15918           if (i.gt.1) &
15919           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
15920                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
15921                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
15922                  *sss_ele_cut
15923           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
15924                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
15925                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
15926                  *sss_ele_cut
15927            xtemp(1)=xj
15928            xtemp(2)=yj
15929            xtemp(3)=zj
15930
15931 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
15932           do l=1,3
15933             ggg(l)=(agg(l,1)*muij(1)+ &
15934                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
15935             *sss_ele_cut &
15936              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
15937
15938             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
15939             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
15940 !grad            ghalf=0.5d0*ggg(l)
15941 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
15942 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
15943           enddo
15944 !grad          do k=i+1,j2
15945 !grad            do l=1,3
15946 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
15947 !grad            enddo
15948 !grad          enddo
15949 ! Remaining derivatives of eello
15950           do l=1,3
15951             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
15952                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
15953             *sss_ele_cut
15954
15955             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
15956                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
15957             *sss_ele_cut
15958
15959             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
15960                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
15961             *sss_ele_cut
15962
15963             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
15964                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
15965             *sss_ele_cut
15966
15967           enddo
15968           ENDIF
15969 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
15970 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
15971           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
15972              .and. num_conti.le.maxconts) then
15973 !            write (iout,*) i,j," entered corr"
15974 !
15975 ! Calculate the contact function. The ith column of the array JCONT will
15976 ! contain the numbers of atoms that make contacts with the atom I (of numbers
15977 ! greater than I). The arrays FACONT and GACONT will contain the values of
15978 ! the contact function and its derivative.
15979 !           r0ij=1.02D0*rpp(iteli,itelj)
15980 !           r0ij=1.11D0*rpp(iteli,itelj)
15981             r0ij=2.20D0*rpp(iteli,itelj)
15982 !           r0ij=1.55D0*rpp(iteli,itelj)
15983             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
15984 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15985             if (fcont.gt.0.0D0) then
15986               num_conti=num_conti+1
15987               if (num_conti.gt.maxconts) then
15988 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15989                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
15990                                ' will skip next contacts for this conf.',num_conti
15991               else
15992                 jcont_hb(num_conti,i)=j
15993 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
15994 !d     &           " jcont_hb",jcont_hb(num_conti,i)
15995                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
15996                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15997 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
15998 !  terms.
15999                 d_cont(num_conti,i)=rij
16000 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
16001 !     --- Electrostatic-interaction matrix ---
16002                 a_chuj(1,1,num_conti,i)=a22
16003                 a_chuj(1,2,num_conti,i)=a23
16004                 a_chuj(2,1,num_conti,i)=a32
16005                 a_chuj(2,2,num_conti,i)=a33
16006 !     --- Gradient of rij
16007                 do kkk=1,3
16008                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
16009                 enddo
16010                 kkll=0
16011                 do k=1,2
16012                   do l=1,2
16013                     kkll=kkll+1
16014                     do m=1,3
16015                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
16016                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
16017                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
16018                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
16019                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
16020                     enddo
16021                   enddo
16022                 enddo
16023                 ENDIF
16024                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
16025 ! Calculate contact energies
16026                 cosa4=4.0D0*cosa
16027                 wij=cosa-3.0D0*cosb*cosg
16028                 cosbg1=cosb+cosg
16029                 cosbg2=cosb-cosg
16030 !               fac3=dsqrt(-ael6i)/r0ij**3
16031                 fac3=dsqrt(-ael6i)*r3ij
16032 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
16033                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
16034                 if (ees0tmp.gt.0) then
16035                   ees0pij=dsqrt(ees0tmp)
16036                 else
16037                   ees0pij=0
16038                 endif
16039 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
16040                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
16041                 if (ees0tmp.gt.0) then
16042                   ees0mij=dsqrt(ees0tmp)
16043                 else
16044                   ees0mij=0
16045                 endif
16046 !               ees0mij=0.0D0
16047                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
16048                      *sss_ele_cut
16049
16050                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
16051                      *sss_ele_cut
16052
16053 ! Diagnostics. Comment out or remove after debugging!
16054 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
16055 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
16056 !               ees0m(num_conti,i)=0.0D0
16057 ! End diagnostics.
16058 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
16059 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
16060 ! Angular derivatives of the contact function
16061                 ees0pij1=fac3/ees0pij
16062                 ees0mij1=fac3/ees0mij
16063                 fac3p=-3.0D0*fac3*rrmij
16064                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
16065                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
16066 !               ees0mij1=0.0D0
16067                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
16068                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
16069                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
16070                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
16071                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
16072                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
16073                 ecosap=ecosa1+ecosa2
16074                 ecosbp=ecosb1+ecosb2
16075                 ecosgp=ecosg1+ecosg2
16076                 ecosam=ecosa1-ecosa2
16077                 ecosbm=ecosb1-ecosb2
16078                 ecosgm=ecosg1-ecosg2
16079 ! Diagnostics
16080 !               ecosap=ecosa1
16081 !               ecosbp=ecosb1
16082 !               ecosgp=ecosg1
16083 !               ecosam=0.0D0
16084 !               ecosbm=0.0D0
16085 !               ecosgm=0.0D0
16086 ! End diagnostics
16087                 facont_hb(num_conti,i)=fcont
16088                 fprimcont=fprimcont/rij
16089 !d              facont_hb(num_conti,i)=1.0D0
16090 ! Following line is for diagnostics.
16091 !d              fprimcont=0.0D0
16092                 do k=1,3
16093                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
16094                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
16095                 enddo
16096                 do k=1,3
16097                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
16098                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
16099                 enddo
16100 !                gggp(1)=gggp(1)+ees0pijp*xj
16101 !                gggp(2)=gggp(2)+ees0pijp*yj
16102 !                gggp(3)=gggp(3)+ees0pijp*zj
16103 !                gggm(1)=gggm(1)+ees0mijp*xj
16104 !                gggm(2)=gggm(2)+ees0mijp*yj
16105 !                gggm(3)=gggm(3)+ees0mijp*zj
16106                 gggp(1)=gggp(1)+ees0pijp*xj &
16107                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
16108                 gggp(2)=gggp(2)+ees0pijp*yj &
16109                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
16110                 gggp(3)=gggp(3)+ees0pijp*zj &
16111                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
16112
16113                 gggm(1)=gggm(1)+ees0mijp*xj &
16114                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
16115
16116                 gggm(2)=gggm(2)+ees0mijp*yj &
16117                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
16118
16119                 gggm(3)=gggm(3)+ees0mijp*zj &
16120                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
16121
16122 ! Derivatives due to the contact function
16123                 gacont_hbr(1,num_conti,i)=fprimcont*xj
16124                 gacont_hbr(2,num_conti,i)=fprimcont*yj
16125                 gacont_hbr(3,num_conti,i)=fprimcont*zj
16126                 do k=1,3
16127 !
16128 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
16129 !          following the change of gradient-summation algorithm.
16130 !
16131 !grad                  ghalfp=0.5D0*gggp(k)
16132 !grad                  ghalfm=0.5D0*gggm(k)
16133 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
16134 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16135 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
16136 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
16137 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16138 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
16139 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
16140 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
16141 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16142 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
16143 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
16144 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16145 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
16146 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
16147                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
16148                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16149                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
16150                      *sss_ele_cut
16151
16152                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
16153                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16154                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
16155                      *sss_ele_cut
16156
16157                   gacontp_hb3(k,num_conti,i)=gggp(k) &
16158                      *sss_ele_cut
16159
16160                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
16161                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16162                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
16163                      *sss_ele_cut
16164
16165                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
16166                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16167                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
16168                      *sss_ele_cut
16169
16170                   gacontm_hb3(k,num_conti,i)=gggm(k) &
16171                      *sss_ele_cut
16172
16173                 enddo
16174               ENDIF ! wcorr
16175               endif  ! num_conti.le.maxconts
16176             endif  ! fcont.gt.0
16177           endif    ! j.gt.i+1
16178           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
16179             do k=1,4
16180               do l=1,3
16181                 ghalf=0.5d0*agg(l,k)
16182                 aggi(l,k)=aggi(l,k)+ghalf
16183                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
16184                 aggj(l,k)=aggj(l,k)+ghalf
16185               enddo
16186             enddo
16187             if (j.eq.nres-1 .and. i.lt.j-2) then
16188               do k=1,4
16189                 do l=1,3
16190                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
16191                 enddo
16192               enddo
16193             endif
16194           endif
16195  128      continue
16196 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
16197       return
16198       end subroutine eelecij_scale
16199 !-----------------------------------------------------------------------------
16200       subroutine evdwpp_short(evdw1)
16201 !
16202 ! Compute Evdwpp
16203 !
16204 !      implicit real*8 (a-h,o-z)
16205 !      include 'DIMENSIONS'
16206 !      include 'COMMON.CONTROL'
16207 !      include 'COMMON.IOUNITS'
16208 !      include 'COMMON.GEO'
16209 !      include 'COMMON.VAR'
16210 !      include 'COMMON.LOCAL'
16211 !      include 'COMMON.CHAIN'
16212 !      include 'COMMON.DERIV'
16213 !      include 'COMMON.INTERACT'
16214 !      include 'COMMON.CONTACTS'
16215 !      include 'COMMON.TORSION'
16216 !      include 'COMMON.VECTORS'
16217 !      include 'COMMON.FFIELD'
16218       real(kind=8),dimension(3) :: ggg
16219 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
16220 #ifdef MOMENT
16221       real(kind=8) :: scal_el=1.0d0
16222 #else
16223       real(kind=8) :: scal_el=0.5d0
16224 #endif
16225 !el local variables
16226       integer :: i,j,k,iteli,itelj,num_conti,isubchap
16227       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
16228       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
16229                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
16230                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
16231       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16232                     dist_temp, dist_init,sss_grad,sslipi,ssgradlipi,&
16233                    sslipj,ssgradlipj,faclipij2
16234       integer xshift,yshift,zshift
16235
16236
16237       evdw1=0.0D0
16238 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
16239 !     & " iatel_e_vdw",iatel_e_vdw
16240       call flush(iout)
16241       do i=iatel_s_vdw,iatel_e_vdw
16242         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
16243         dxi=dc(1,i)
16244         dyi=dc(2,i)
16245         dzi=dc(3,i)
16246         dx_normi=dc_norm(1,i)
16247         dy_normi=dc_norm(2,i)
16248         dz_normi=dc_norm(3,i)
16249         xmedi=c(1,i)+0.5d0*dxi
16250         ymedi=c(2,i)+0.5d0*dyi
16251         zmedi=c(3,i)+0.5d0*dzi
16252         call to_box(xmedi,ymedi,zmedi)
16253         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
16254         num_conti=0
16255 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
16256 !     &   ' ielend',ielend_vdw(i)
16257         call flush(iout)
16258         do j=ielstart_vdw(i),ielend_vdw(i)
16259           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
16260 !el          ind=ind+1
16261           iteli=itel(i)
16262           itelj=itel(j)
16263           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
16264           aaa=app(iteli,itelj)
16265           bbb=bpp(iteli,itelj)
16266           dxj=dc(1,j)
16267           dyj=dc(2,j)
16268           dzj=dc(3,j)
16269           dx_normj=dc_norm(1,j)
16270           dy_normj=dc_norm(2,j)
16271           dz_normj=dc_norm(3,j)
16272 !          xj=c(1,j)+0.5D0*dxj-xmedi
16273 !          yj=c(2,j)+0.5D0*dyj-ymedi
16274 !          zj=c(3,j)+0.5D0*dzj-zmedi
16275           xj=c(1,j)+0.5D0*dxj
16276           yj=c(2,j)+0.5D0*dyj
16277           zj=c(3,j)+0.5D0*dzj
16278           call to_box(xj,yj,zj)
16279           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
16280           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
16281           xj=boxshift(xj-xmedi,boxxsize)
16282           yj=boxshift(yj-ymedi,boxysize)
16283           zj=boxshift(zj-zmedi,boxzsize)
16284           rij=xj*xj+yj*yj+zj*zj
16285           rrmij=1.0D0/rij
16286           rij=dsqrt(rij)
16287           sss=sscale(rij/rpp(iteli,itelj))
16288             sss_ele_cut=sscale_ele(rij)
16289             sss_ele_grad=sscagrad_ele(rij)
16290             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
16291             if (sss_ele_cut.le.0.0) cycle
16292           if (sss.gt.0.0d0) then
16293             rmij=1.0D0/rij
16294             r3ij=rrmij*rmij
16295             r6ij=r3ij*r3ij
16296             ev1=aaa*r6ij*r6ij
16297 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
16298             if (j.eq.i+2) ev1=scal_el*ev1
16299             ev2=bbb*r6ij
16300             evdwij=ev1+ev2
16301             if (energy_dec) then
16302               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
16303             endif
16304             evdw1=evdw1+evdwij*sss*sss_ele_cut
16305 !
16306 ! Calculate contributions to the Cartesian gradient.
16307 !
16308             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
16309 !            ggg(1)=facvdw*xj
16310 !            ggg(2)=facvdw*yj
16311 !            ggg(3)=facvdw*zj
16312           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
16313           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
16314           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
16315           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
16316           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
16317           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
16318
16319             do k=1,3
16320               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
16321               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
16322             enddo
16323           endif
16324         enddo ! j
16325       enddo   ! i
16326       return
16327       end subroutine evdwpp_short
16328 !-----------------------------------------------------------------------------
16329       subroutine escp_long(evdw2,evdw2_14)
16330 !
16331 ! This subroutine calculates the excluded-volume interaction energy between
16332 ! peptide-group centers and side chains and its gradient in virtual-bond and
16333 ! side-chain vectors.
16334 !
16335 !      implicit real*8 (a-h,o-z)
16336 !      include 'DIMENSIONS'
16337 !      include 'COMMON.GEO'
16338 !      include 'COMMON.VAR'
16339 !      include 'COMMON.LOCAL'
16340 !      include 'COMMON.CHAIN'
16341 !      include 'COMMON.DERIV'
16342 !      include 'COMMON.INTERACT'
16343 !      include 'COMMON.FFIELD'
16344 !      include 'COMMON.IOUNITS'
16345 !      include 'COMMON.CONTROL'
16346       real(kind=8),dimension(3) :: ggg
16347 !el local variables
16348       integer :: i,iint,j,k,iteli,itypj,subchap
16349       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
16350       real(kind=8) :: evdw2,evdw2_14,evdwij
16351       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16352                     dist_temp, dist_init
16353
16354       evdw2=0.0D0
16355       evdw2_14=0.0d0
16356 !d    print '(a)','Enter ESCP'
16357 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16358       do i=iatscp_s,iatscp_e
16359         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16360         iteli=itel(i)
16361         xi=0.5D0*(c(1,i)+c(1,i+1))
16362         yi=0.5D0*(c(2,i)+c(2,i+1))
16363         zi=0.5D0*(c(3,i)+c(3,i+1))
16364         call to_box(xi,yi,zi)
16365         do iint=1,nscp_gr(i)
16366
16367         do j=iscpstart(i,iint),iscpend(i,iint)
16368           itypj=itype(j,1)
16369           if (itypj.eq.ntyp1) cycle
16370 ! Uncomment following three lines for SC-p interactions
16371 !         xj=c(1,nres+j)-xi
16372 !         yj=c(2,nres+j)-yi
16373 !         zj=c(3,nres+j)-zi
16374 ! Uncomment following three lines for Ca-p interactions
16375           xj=c(1,j)
16376           yj=c(2,j)
16377           zj=c(3,j)
16378           call to_box(xj,yj,zj)
16379           xj=boxshift(xj-xi,boxxsize)
16380           yj=boxshift(yj-yi,boxysize)
16381           zj=boxshift(zj-zi,boxzsize)
16382           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16383
16384           rij=dsqrt(1.0d0/rrij)
16385             sss_ele_cut=sscale_ele(rij)
16386             sss_ele_grad=sscagrad_ele(rij)
16387 !            print *,sss_ele_cut,sss_ele_grad,&
16388 !            (rij),r_cut_ele,rlamb_ele
16389             if (sss_ele_cut.le.0.0) cycle
16390           sss=sscale((rij/rscp(itypj,iteli)))
16391           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16392           if (sss.lt.1.0d0) then
16393
16394             fac=rrij**expon2
16395             e1=fac*fac*aad(itypj,iteli)
16396             e2=fac*bad(itypj,iteli)
16397             if (iabs(j-i) .le. 2) then
16398               e1=scal14*e1
16399               e2=scal14*e2
16400               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
16401             endif
16402             evdwij=e1+e2
16403             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
16404             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16405                 'evdw2',i,j,sss,evdwij
16406 !
16407 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16408 !
16409             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
16410             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
16411             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16412             ggg(1)=xj*fac
16413             ggg(2)=yj*fac
16414             ggg(3)=zj*fac
16415 ! Uncomment following three lines for SC-p interactions
16416 !           do k=1,3
16417 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16418 !           enddo
16419 ! Uncomment following line for SC-p interactions
16420 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16421             do k=1,3
16422               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16423               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16424             enddo
16425           endif
16426         enddo
16427
16428         enddo ! iint
16429       enddo ! i
16430       do i=1,nct
16431         do j=1,3
16432           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16433           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16434           gradx_scp(j,i)=expon*gradx_scp(j,i)
16435         enddo
16436       enddo
16437 !******************************************************************************
16438 !
16439 !                              N O T E !!!
16440 !
16441 ! To save time the factor EXPON has been extracted from ALL components
16442 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16443 ! use!
16444 !
16445 !******************************************************************************
16446       return
16447       end subroutine escp_long
16448 !-----------------------------------------------------------------------------
16449       subroutine escp_short(evdw2,evdw2_14)
16450 !
16451 ! This subroutine calculates the excluded-volume interaction energy between
16452 ! peptide-group centers and side chains and its gradient in virtual-bond and
16453 ! side-chain vectors.
16454 !
16455 !      implicit real*8 (a-h,o-z)
16456 !      include 'DIMENSIONS'
16457 !      include 'COMMON.GEO'
16458 !      include 'COMMON.VAR'
16459 !      include 'COMMON.LOCAL'
16460 !      include 'COMMON.CHAIN'
16461 !      include 'COMMON.DERIV'
16462 !      include 'COMMON.INTERACT'
16463 !      include 'COMMON.FFIELD'
16464 !      include 'COMMON.IOUNITS'
16465 !      include 'COMMON.CONTROL'
16466       real(kind=8),dimension(3) :: ggg
16467 !el local variables
16468       integer :: i,iint,j,k,iteli,itypj,subchap
16469       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
16470       real(kind=8) :: evdw2,evdw2_14,evdwij
16471       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16472                     dist_temp, dist_init
16473
16474       evdw2=0.0D0
16475       evdw2_14=0.0d0
16476 !d    print '(a)','Enter ESCP'
16477 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16478       do i=iatscp_s,iatscp_e
16479         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16480         iteli=itel(i)
16481         xi=0.5D0*(c(1,i)+c(1,i+1))
16482         yi=0.5D0*(c(2,i)+c(2,i+1))
16483         zi=0.5D0*(c(3,i)+c(3,i+1))
16484         call to_box(xi,yi,zi)
16485         if (zi.lt.0) zi=zi+boxzsize
16486
16487         do iint=1,nscp_gr(i)
16488
16489         do j=iscpstart(i,iint),iscpend(i,iint)
16490           itypj=itype(j,1)
16491           if (itypj.eq.ntyp1) cycle
16492 ! Uncomment following three lines for SC-p interactions
16493 !         xj=c(1,nres+j)-xi
16494 !         yj=c(2,nres+j)-yi
16495 !         zj=c(3,nres+j)-zi
16496 ! Uncomment following three lines for Ca-p interactions
16497 !          xj=c(1,j)-xi
16498 !          yj=c(2,j)-yi
16499 !          zj=c(3,j)-zi
16500           xj=c(1,j)
16501           yj=c(2,j)
16502           zj=c(3,j)
16503           call to_box(xj,yj,zj)
16504           xj=boxshift(xj-xi,boxxsize)
16505           yj=boxshift(yj-yi,boxysize)
16506           zj=boxshift(zj-zi,boxzsize)
16507           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16508           rij=dsqrt(1.0d0/rrij)
16509             sss_ele_cut=sscale_ele(rij)
16510             sss_ele_grad=sscagrad_ele(rij)
16511 !            print *,sss_ele_cut,sss_ele_grad,&
16512 !            (rij),r_cut_ele,rlamb_ele
16513             if (sss_ele_cut.le.0.0) cycle
16514           sss=sscale(rij/rscp(itypj,iteli))
16515           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16516           if (sss.gt.0.0d0) then
16517
16518             fac=rrij**expon2
16519             e1=fac*fac*aad(itypj,iteli)
16520             e2=fac*bad(itypj,iteli)
16521             if (iabs(j-i) .le. 2) then
16522               e1=scal14*e1
16523               e2=scal14*e2
16524               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
16525             endif
16526             evdwij=e1+e2
16527             evdw2=evdw2+evdwij*sss*sss_ele_cut
16528             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16529                 'evdw2',i,j,sss,evdwij
16530 !
16531 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16532 !
16533             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
16534             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
16535             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16536
16537             ggg(1)=xj*fac
16538             ggg(2)=yj*fac
16539             ggg(3)=zj*fac
16540 ! Uncomment following three lines for SC-p interactions
16541 !           do k=1,3
16542 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16543 !           enddo
16544 ! Uncomment following line for SC-p interactions
16545 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16546             do k=1,3
16547               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16548               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16549             enddo
16550           endif
16551         enddo
16552
16553         enddo ! iint
16554       enddo ! i
16555       do i=1,nct
16556         do j=1,3
16557           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16558           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16559           gradx_scp(j,i)=expon*gradx_scp(j,i)
16560         enddo
16561       enddo
16562 !******************************************************************************
16563 !
16564 !                              N O T E !!!
16565 !
16566 ! To save time the factor EXPON has been extracted from ALL components
16567 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16568 ! use!
16569 !
16570 !******************************************************************************
16571       return
16572       end subroutine escp_short
16573 !-----------------------------------------------------------------------------
16574 ! energy_p_new-sep_barrier.F
16575 !-----------------------------------------------------------------------------
16576       subroutine sc_grad_scale(scalfac)
16577 !      implicit real*8 (a-h,o-z)
16578       use calc_data
16579 !      include 'DIMENSIONS'
16580 !      include 'COMMON.CHAIN'
16581 !      include 'COMMON.DERIV'
16582 !      include 'COMMON.CALC'
16583 !      include 'COMMON.IOUNITS'
16584       real(kind=8),dimension(3) :: dcosom1,dcosom2
16585       real(kind=8) :: scalfac
16586 !el local variables
16587 !      integer :: i,j,k,l
16588
16589       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
16590       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
16591       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
16592            -2.0D0*alf12*eps3der+sigder*sigsq_om12
16593 ! diagnostics only
16594 !      eom1=0.0d0
16595 !      eom2=0.0d0
16596 !      eom12=evdwij*eps1_om12
16597 ! end diagnostics
16598 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
16599 !     &  " sigder",sigder
16600 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
16601 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
16602       do k=1,3
16603         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
16604         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
16605       enddo
16606       do k=1,3
16607         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
16608          *sss_ele_cut
16609       enddo
16610 !      write (iout,*) "gg",(gg(k),k=1,3)
16611       do k=1,3
16612         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
16613                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
16614                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
16615                  *sss_ele_cut
16616         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
16617                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
16618                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
16619          *sss_ele_cut
16620 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
16621 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
16622 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
16623 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
16624       enddo
16625 !
16626 ! Calculate the components of the gradient in DC and X
16627 !
16628       do l=1,3
16629         gvdwc(l,i)=gvdwc(l,i)-gg(l)
16630         gvdwc(l,j)=gvdwc(l,j)+gg(l)
16631       enddo
16632       return
16633       end subroutine sc_grad_scale
16634 !-----------------------------------------------------------------------------
16635 ! energy_split-sep.F
16636 !-----------------------------------------------------------------------------
16637       subroutine etotal_long(energia)
16638 !
16639 ! Compute the long-range slow-varying contributions to the energy
16640 !
16641 !      implicit real*8 (a-h,o-z)
16642 !      include 'DIMENSIONS'
16643       use MD_data, only: totT,usampl,eq_time
16644 #ifndef ISNAN
16645       external proc_proc
16646 #ifdef WINPGI
16647 !MS$ATTRIBUTES C ::  proc_proc
16648 #endif
16649 #endif
16650 #ifdef MPI
16651       include "mpif.h"
16652       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
16653 #endif
16654 !      include 'COMMON.SETUP'
16655 !      include 'COMMON.IOUNITS'
16656 !      include 'COMMON.FFIELD'
16657 !      include 'COMMON.DERIV'
16658 !      include 'COMMON.INTERACT'
16659 !      include 'COMMON.SBRIDGE'
16660 !      include 'COMMON.CHAIN'
16661 !      include 'COMMON.VAR'
16662 !      include 'COMMON.LOCAL'
16663 !      include 'COMMON.MD'
16664       real(kind=8),dimension(0:n_ene) :: energia
16665 !el local variables
16666       integer :: i,n_corr,n_corr1,ierror,ierr
16667       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
16668                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
16669                   ecorr,ecorr5,ecorr6,eturn6,time00, ehomology_constr
16670 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
16671 !elwrite(iout,*)"in etotal long"
16672
16673       if (modecalc.eq.12.or.modecalc.eq.14) then
16674 #ifdef MPI
16675 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
16676 #else
16677         call int_from_cart1(.false.)
16678 #endif
16679       endif
16680 !elwrite(iout,*)"in etotal long"
16681       ehomology_constr=0.0d0
16682 #ifdef MPI
16683 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
16684 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16685       call flush(iout)
16686       if (nfgtasks.gt.1) then
16687         time00=MPI_Wtime()
16688 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16689         if (fg_rank.eq.0) then
16690           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
16691 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16692 !          call flush(iout)
16693 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16694 ! FG slaves as WEIGHTS array.
16695           weights_(1)=wsc
16696           weights_(2)=wscp
16697           weights_(3)=welec
16698           weights_(4)=wcorr
16699           weights_(5)=wcorr5
16700           weights_(6)=wcorr6
16701           weights_(7)=wel_loc
16702           weights_(8)=wturn3
16703           weights_(9)=wturn4
16704           weights_(10)=wturn6
16705           weights_(11)=wang
16706           weights_(12)=wscloc
16707           weights_(13)=wtor
16708           weights_(14)=wtor_d
16709           weights_(15)=wstrain
16710           weights_(16)=wvdwpp
16711           weights_(17)=wbond
16712           weights_(18)=scal14
16713           weights_(21)=wsccor
16714 ! FG Master broadcasts the WEIGHTS_ array
16715           call MPI_Bcast(weights_(1),n_ene,&
16716               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16717         else
16718 ! FG slaves receive the WEIGHTS array
16719           call MPI_Bcast(weights(1),n_ene,&
16720               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16721           wsc=weights(1)
16722           wscp=weights(2)
16723           welec=weights(3)
16724           wcorr=weights(4)
16725           wcorr5=weights(5)
16726           wcorr6=weights(6)
16727           wel_loc=weights(7)
16728           wturn3=weights(8)
16729           wturn4=weights(9)
16730           wturn6=weights(10)
16731           wang=weights(11)
16732           wscloc=weights(12)
16733           wtor=weights(13)
16734           wtor_d=weights(14)
16735           wstrain=weights(15)
16736           wvdwpp=weights(16)
16737           wbond=weights(17)
16738           scal14=weights(18)
16739           wsccor=weights(21)
16740         endif
16741         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
16742           king,FG_COMM,IERR)
16743          time_Bcast=time_Bcast+MPI_Wtime()-time00
16744          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
16745 !        call chainbuild_cart
16746 !        call int_from_cart1(.false.)
16747       endif
16748 !      write (iout,*) 'Processor',myrank,
16749 !     &  ' calling etotal_short ipot=',ipot
16750 !      call flush(iout)
16751 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16752 #endif
16753 !d    print *,'nnt=',nnt,' nct=',nct
16754 !
16755 !elwrite(iout,*)"in etotal long"
16756 ! Compute the side-chain and electrostatic interaction energy
16757 !
16758       goto (101,102,103,104,105,106) ipot
16759 ! Lennard-Jones potential.
16760   101 call elj_long(evdw)
16761 !d    print '(a)','Exit ELJ'
16762       goto 107
16763 ! Lennard-Jones-Kihara potential (shifted).
16764   102 call eljk_long(evdw)
16765       goto 107
16766 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16767   103 call ebp_long(evdw)
16768       goto 107
16769 ! Gay-Berne potential (shifted LJ, angular dependence).
16770   104 call egb_long(evdw)
16771       goto 107
16772 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16773   105 call egbv_long(evdw)
16774       goto 107
16775 ! Soft-sphere potential
16776   106 call e_softsphere(evdw)
16777 !
16778 ! Calculate electrostatic (H-bonding) energy of the main chain.
16779 !
16780   107 continue
16781       call vec_and_deriv
16782       if (ipot.lt.6) then
16783 #ifdef SPLITELE
16784          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
16785              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16786              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16787              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16788 #else
16789          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
16790              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16791              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16792              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16793 #endif
16794            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
16795          else
16796             ees=0
16797             evdw1=0
16798             eel_loc=0
16799             eello_turn3=0
16800             eello_turn4=0
16801          endif
16802       else
16803 !        write (iout,*) "Soft-spheer ELEC potential"
16804         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
16805          eello_turn4)
16806       endif
16807 !
16808 ! Calculate excluded-volume interaction energy between peptide groups
16809 ! and side chains.
16810 !
16811       if (ipot.lt.6) then
16812        if(wscp.gt.0d0) then
16813         call escp_long(evdw2,evdw2_14)
16814        else
16815         evdw2=0
16816         evdw2_14=0
16817        endif
16818       else
16819         call escp_soft_sphere(evdw2,evdw2_14)
16820       endif
16821 !
16822 ! 12/1/95 Multi-body terms
16823 !
16824       n_corr=0
16825       n_corr1=0
16826       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
16827           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
16828          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
16829 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
16830 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
16831       else
16832          ecorr=0.0d0
16833          ecorr5=0.0d0
16834          ecorr6=0.0d0
16835          eturn6=0.0d0
16836       endif
16837       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
16838          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
16839       endif
16840 !
16841 ! If performing constraint dynamics, call the constraint energy
16842 !  after the equilibration time
16843       if(usampl.and.totT.gt.eq_time) then
16844          call EconstrQ
16845          call Econstr_back
16846       else
16847          Uconst=0.0d0
16848          Uconst_back=0.0d0
16849       endif
16850 !
16851 ! Sum the energies
16852 !
16853       do i=1,n_ene
16854         energia(i)=0.0d0
16855       enddo
16856       energia(1)=evdw
16857 #ifdef SCP14
16858       energia(2)=evdw2-evdw2_14
16859       energia(18)=evdw2_14
16860 #else
16861       energia(2)=evdw2
16862       energia(18)=0.0d0
16863 #endif
16864 #ifdef SPLITELE
16865       energia(3)=ees
16866       energia(16)=evdw1
16867 #else
16868       energia(3)=ees+evdw1
16869       energia(16)=0.0d0
16870 #endif
16871       energia(4)=ecorr
16872       energia(5)=ecorr5
16873       energia(6)=ecorr6
16874       energia(7)=eel_loc
16875       energia(8)=eello_turn3
16876       energia(9)=eello_turn4
16877       energia(10)=eturn6
16878       energia(20)=Uconst+Uconst_back
16879       energia(51)=ehomology_constr
16880       call sum_energy(energia,.true.)
16881 !      write (iout,*) "Exit ETOTAL_LONG"
16882       call flush(iout)
16883       return
16884       end subroutine etotal_long
16885 !-----------------------------------------------------------------------------
16886       subroutine etotal_short(energia)
16887 !
16888 ! Compute the short-range fast-varying contributions to the energy
16889 !
16890 !      implicit real*8 (a-h,o-z)
16891 !      include 'DIMENSIONS'
16892 #ifndef ISNAN
16893       external proc_proc
16894 #ifdef WINPGI
16895 !MS$ATTRIBUTES C ::  proc_proc
16896 #endif
16897 #endif
16898 #ifdef MPI
16899       include "mpif.h"
16900       integer :: ierror,ierr
16901       real(kind=8),dimension(n_ene) :: weights_
16902       real(kind=8) :: time00
16903 #endif
16904 !      include 'COMMON.SETUP'
16905 !      include 'COMMON.IOUNITS'
16906 !      include 'COMMON.FFIELD'
16907 !      include 'COMMON.DERIV'
16908 !      include 'COMMON.INTERACT'
16909 !      include 'COMMON.SBRIDGE'
16910 !      include 'COMMON.CHAIN'
16911 !      include 'COMMON.VAR'
16912 !      include 'COMMON.LOCAL'
16913       real(kind=8),dimension(0:n_ene) :: energia
16914 !el local variables
16915       integer :: i,nres6
16916       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
16917       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr, &
16918                       ehomology_constr
16919       nres6=6*nres
16920
16921 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
16922 !      call flush(iout)
16923       if (modecalc.eq.12.or.modecalc.eq.14) then
16924 #ifdef MPI
16925         if (fg_rank.eq.0) call int_from_cart1(.false.)
16926 #else
16927         call int_from_cart1(.false.)
16928 #endif
16929       endif
16930 #ifdef MPI
16931 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
16932 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16933 !      call flush(iout)
16934       if (nfgtasks.gt.1) then
16935         time00=MPI_Wtime()
16936 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16937         if (fg_rank.eq.0) then
16938           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
16939 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16940 !          call flush(iout)
16941 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16942 ! FG slaves as WEIGHTS array.
16943           weights_(1)=wsc
16944           weights_(2)=wscp
16945           weights_(3)=welec
16946           weights_(4)=wcorr
16947           weights_(5)=wcorr5
16948           weights_(6)=wcorr6
16949           weights_(7)=wel_loc
16950           weights_(8)=wturn3
16951           weights_(9)=wturn4
16952           weights_(10)=wturn6
16953           weights_(11)=wang
16954           weights_(12)=wscloc
16955           weights_(13)=wtor
16956           weights_(14)=wtor_d
16957           weights_(15)=wstrain
16958           weights_(16)=wvdwpp
16959           weights_(17)=wbond
16960           weights_(18)=scal14
16961           weights_(21)=wsccor
16962 ! FG Master broadcasts the WEIGHTS_ array
16963           call MPI_Bcast(weights_(1),n_ene,&
16964               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16965         else
16966 ! FG slaves receive the WEIGHTS array
16967           call MPI_Bcast(weights(1),n_ene,&
16968               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16969           wsc=weights(1)
16970           wscp=weights(2)
16971           welec=weights(3)
16972           wcorr=weights(4)
16973           wcorr5=weights(5)
16974           wcorr6=weights(6)
16975           wel_loc=weights(7)
16976           wturn3=weights(8)
16977           wturn4=weights(9)
16978           wturn6=weights(10)
16979           wang=weights(11)
16980           wscloc=weights(12)
16981           wtor=weights(13)
16982           wtor_d=weights(14)
16983           wstrain=weights(15)
16984           wvdwpp=weights(16)
16985           wbond=weights(17)
16986           scal14=weights(18)
16987           wsccor=weights(21)
16988         endif
16989 !        write (iout,*),"Processor",myrank," BROADCAST weights"
16990         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
16991           king,FG_COMM,IERR)
16992 !        write (iout,*) "Processor",myrank," BROADCAST c"
16993         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
16994           king,FG_COMM,IERR)
16995 !        write (iout,*) "Processor",myrank," BROADCAST dc"
16996         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
16997           king,FG_COMM,IERR)
16998 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
16999         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
17000           king,FG_COMM,IERR)
17001 !        write (iout,*) "Processor",myrank," BROADCAST theta"
17002         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
17003           king,FG_COMM,IERR)
17004 !        write (iout,*) "Processor",myrank," BROADCAST phi"
17005         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
17006           king,FG_COMM,IERR)
17007 !        write (iout,*) "Processor",myrank," BROADCAST alph"
17008         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
17009           king,FG_COMM,IERR)
17010 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
17011         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
17012           king,FG_COMM,IERR)
17013 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
17014         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
17015           king,FG_COMM,IERR)
17016          time_Bcast=time_Bcast+MPI_Wtime()-time00
17017 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
17018       endif
17019 !      write (iout,*) 'Processor',myrank,
17020 !     &  ' calling etotal_short ipot=',ipot
17021 !      call flush(iout)
17022 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
17023 #endif
17024 !      call int_from_cart1(.false.)
17025 !
17026 ! Compute the side-chain and electrostatic interaction energy
17027 !
17028       goto (101,102,103,104,105,106) ipot
17029 ! Lennard-Jones potential.
17030   101 call elj_short(evdw)
17031 !d    print '(a)','Exit ELJ'
17032       goto 107
17033 ! Lennard-Jones-Kihara potential (shifted).
17034   102 call eljk_short(evdw)
17035       goto 107
17036 ! Berne-Pechukas potential (dilated LJ, angular dependence).
17037   103 call ebp_short(evdw)
17038       goto 107
17039 ! Gay-Berne potential (shifted LJ, angular dependence).
17040   104 call egb_short(evdw)
17041       goto 107
17042 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
17043   105 call egbv_short(evdw)
17044       goto 107
17045 ! Soft-sphere potential - already dealt with in the long-range part
17046   106 evdw=0.0d0
17047 !  106 call e_softsphere_short(evdw)
17048 !
17049 ! Calculate electrostatic (H-bonding) energy of the main chain.
17050 !
17051   107 continue
17052 !
17053 ! Calculate the short-range part of Evdwpp
17054 !
17055       call evdwpp_short(evdw1)
17056 !
17057 ! Calculate the short-range part of ESCp
17058 !
17059       if (ipot.lt.6) then
17060        call escp_short(evdw2,evdw2_14)
17061       endif
17062 !
17063 ! Calculate the bond-stretching energy
17064 !
17065       call ebond(estr)
17066 !
17067 ! Calculate the disulfide-bridge and other energy and the contributions
17068 ! from other distance constraints.
17069       call edis(ehpb)
17070 !
17071 ! Calculate the virtual-bond-angle energy.
17072 !
17073 ! Calculate the SC local energy.
17074 !
17075       call vec_and_deriv
17076       call esc(escloc)
17077 !
17078       if (wang.gt.0d0) then
17079        if (tor_mode.eq.0) then
17080            call ebend(ebe)
17081        else
17082 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
17083 !C energy function
17084         call ebend_kcc(ebe)
17085        endif
17086       else
17087           ebe=0.0d0
17088       endif
17089       ethetacnstr=0.0d0
17090       if (with_theta_constr) call etheta_constr(ethetacnstr)
17091
17092 !       write(iout,*) "in etotal afer ebe",ipot
17093
17094 !      print *,"Processor",myrank," computed UB"
17095 !
17096 ! Calculate the SC local energy.
17097 !
17098       call esc(escloc)
17099 !elwrite(iout,*) "in etotal afer esc",ipot
17100 !      print *,"Processor",myrank," computed USC"
17101 !
17102 ! Calculate the virtual-bond torsional energy.
17103 !
17104 !d    print *,'nterm=',nterm
17105 !      if (wtor.gt.0) then
17106 !       call etor(etors,edihcnstr)
17107 !      else
17108 !       etors=0
17109 !       edihcnstr=0
17110 !      endif
17111       if (wtor.gt.0.0d0) then
17112          if (tor_mode.eq.0) then
17113            call etor(etors)
17114           else
17115 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
17116 !C energy function
17117         call etor_kcc(etors)
17118          endif
17119       else
17120            etors=0.0d0
17121       endif
17122       edihcnstr=0.0d0
17123       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
17124
17125 ! Calculate the virtual-bond torsional energy.
17126 !
17127 !
17128 ! 6/23/01 Calculate double-torsional energy
17129 !
17130       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
17131       call etor_d(etors_d)
17132       endif
17133 !
17134 ! Homology restraints
17135 !
17136       if (constr_homology.ge.1) then
17137         call e_modeller(ehomology_constr)
17138 !      print *,"tu"
17139       else
17140         ehomology_constr=0.0d0
17141       endif
17142
17143 !
17144 ! 21/5/07 Calculate local sicdechain correlation energy
17145 !
17146       if (wsccor.gt.0.0d0) then
17147        call eback_sc_corr(esccor)
17148       else
17149        esccor=0.0d0
17150       endif
17151 !
17152 ! Put energy components into an array
17153 !
17154       do i=1,n_ene
17155        energia(i)=0.0d0
17156       enddo
17157       energia(1)=evdw
17158 #ifdef SCP14
17159       energia(2)=evdw2-evdw2_14
17160       energia(18)=evdw2_14
17161 #else
17162       energia(2)=evdw2
17163       energia(18)=0.0d0
17164 #endif
17165 #ifdef SPLITELE
17166       energia(16)=evdw1
17167 #else
17168       energia(3)=evdw1
17169 #endif
17170       energia(11)=ebe
17171       energia(12)=escloc
17172       energia(13)=etors
17173       energia(14)=etors_d
17174       energia(15)=ehpb
17175       energia(17)=estr
17176       energia(19)=edihcnstr
17177       energia(21)=esccor
17178       energia(51)=ehomology_constr
17179 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
17180       call flush(iout)
17181       call sum_energy(energia,.true.)
17182 !      write (iout,*) "Exit ETOTAL_SHORT"
17183       call flush(iout)
17184       return
17185       end subroutine etotal_short
17186 !-----------------------------------------------------------------------------
17187 ! gnmr1.f
17188 !-----------------------------------------------------------------------------
17189       real(kind=8) function gnmr1(y,ymin,ymax)
17190 !      implicit none
17191       real(kind=8) :: y,ymin,ymax
17192       real(kind=8) :: wykl=4.0d0
17193       if (y.lt.ymin) then
17194         gnmr1=(ymin-y)**wykl/wykl
17195       else if (y.gt.ymax) then
17196        gnmr1=(y-ymax)**wykl/wykl
17197       else
17198        gnmr1=0.0d0
17199       endif
17200       return
17201       end function gnmr1
17202 !-----------------------------------------------------------------------------
17203       real(kind=8) function gnmr1prim(y,ymin,ymax)
17204 !      implicit none
17205       real(kind=8) :: y,ymin,ymax
17206       real(kind=8) :: wykl=4.0d0
17207       if (y.lt.ymin) then
17208        gnmr1prim=-(ymin-y)**(wykl-1)
17209       else if (y.gt.ymax) then
17210        gnmr1prim=(y-ymax)**(wykl-1)
17211       else
17212        gnmr1prim=0.0d0
17213       endif
17214       return
17215       end function gnmr1prim
17216 !----------------------------------------------------------------------------
17217       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
17218       real(kind=8) y,ymin,ymax,sigma
17219       real(kind=8) wykl /4.0d0/
17220       if (y.lt.ymin) then
17221         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
17222       else if (y.gt.ymax) then
17223        rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
17224       else
17225         rlornmr1=0.0d0
17226       endif
17227       return
17228       end function rlornmr1
17229 !------------------------------------------------------------------------------
17230       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
17231       real(kind=8) y,ymin,ymax,sigma
17232       real(kind=8) wykl /4.0d0/
17233       if (y.lt.ymin) then
17234         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
17235         ((ymin-y)**wykl+sigma**wykl)**2
17236       else if (y.gt.ymax) then
17237          rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
17238         ((y-ymax)**wykl+sigma**wykl)**2
17239       else
17240        rlornmr1prim=0.0d0
17241       endif
17242       return
17243       end function rlornmr1prim
17244
17245       real(kind=8) function harmonic(y,ymax)
17246 !      implicit none
17247       real(kind=8) :: y,ymax
17248       real(kind=8) :: wykl=2.0d0
17249       harmonic=(y-ymax)**wykl
17250       return
17251       end function harmonic
17252 !-----------------------------------------------------------------------------
17253       real(kind=8) function harmonicprim(y,ymax)
17254       real(kind=8) :: y,ymin,ymax
17255       real(kind=8) :: wykl=2.0d0
17256       harmonicprim=(y-ymax)*wykl
17257       return
17258       end function harmonicprim
17259 !-----------------------------------------------------------------------------
17260 ! gradient_p.F
17261 !-----------------------------------------------------------------------------
17262       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
17263
17264       use io_base, only:intout,briefout
17265 !      implicit real*8 (a-h,o-z)
17266 !      include 'DIMENSIONS'
17267 !      include 'COMMON.CHAIN'
17268 !      include 'COMMON.DERIV'
17269 !      include 'COMMON.VAR'
17270 !      include 'COMMON.INTERACT'
17271 !      include 'COMMON.FFIELD'
17272 !      include 'COMMON.MD'
17273 !      include 'COMMON.IOUNITS'
17274       real(kind=8),external :: ufparm
17275       integer :: uiparm(1)
17276       real(kind=8) :: urparm(1)
17277       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
17278       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
17279       integer :: n,nf,ind,ind1,i,k,j
17280 !
17281 ! This subroutine calculates total internal coordinate gradient.
17282 ! Depending on the number of function evaluations, either whole energy
17283 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
17284 ! internal coordinates are reevaluated or only the cartesian-in-internal
17285 ! coordinate derivatives are evaluated. The subroutine was designed to work
17286 ! with SUMSL.
17287 !
17288 !
17289       icg=mod(nf,2)+1
17290
17291 !d      print *,'grad',nf,icg
17292       if (nf-nfl+1) 20,30,40
17293    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
17294 !    write (iout,*) 'grad 20'
17295       if (nf.eq.0) return
17296       goto 40
17297    30 call var_to_geom(n,x)
17298       call chainbuild
17299 !    write (iout,*) 'grad 30'
17300 !
17301 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
17302 !
17303    40 call cartder
17304 !     write (iout,*) 'grad 40'
17305 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
17306 !
17307 ! Convert the Cartesian gradient into internal-coordinate gradient.
17308 !
17309       ind=0
17310       ind1=0
17311       do i=1,nres-2
17312       gthetai=0.0D0
17313       gphii=0.0D0
17314       do j=i+1,nres-1
17315         ind=ind+1
17316 !         ind=indmat(i,j)
17317 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
17318        do k=1,3
17319        gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
17320         enddo
17321         do k=1,3
17322         gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
17323          enddo
17324        enddo
17325       do j=i+1,nres-1
17326         ind1=ind1+1
17327 !         ind1=indmat(i,j)
17328 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
17329         do k=1,3
17330           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
17331           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
17332           enddo
17333         enddo
17334       if (i.gt.1) g(i-1)=gphii
17335       if (n.gt.nphi) g(nphi+i)=gthetai
17336       enddo
17337       if (n.le.nphi+ntheta) goto 10
17338       do i=2,nres-1
17339       if (itype(i,1).ne.10) then
17340           galphai=0.0D0
17341         gomegai=0.0D0
17342         do k=1,3
17343           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
17344           enddo
17345         do k=1,3
17346           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
17347           enddo
17348           g(ialph(i,1))=galphai
17349         g(ialph(i,1)+nside)=gomegai
17350         endif
17351       enddo
17352 !
17353 ! Add the components corresponding to local energy terms.
17354 !
17355    10 continue
17356       do i=1,nvar
17357 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
17358         g(i)=g(i)+gloc(i,icg)
17359       enddo
17360 ! Uncomment following three lines for diagnostics.
17361 !d    call intout
17362 !elwrite(iout,*) "in gradient after calling intout"
17363 !d    call briefout(0,0.0d0)
17364 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
17365       return
17366       end subroutine gradient
17367 !-----------------------------------------------------------------------------
17368       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
17369
17370       use comm_chu
17371 !      implicit real*8 (a-h,o-z)
17372 !      include 'DIMENSIONS'
17373 !      include 'COMMON.DERIV'
17374 !      include 'COMMON.IOUNITS'
17375 !      include 'COMMON.GEO'
17376       integer :: n,nf
17377 !el      integer :: jjj
17378 !el      common /chuju/ jjj
17379       real(kind=8) :: energia(0:n_ene)
17380       integer :: uiparm(1)
17381       real(kind=8) :: urparm(1)
17382       real(kind=8) :: f
17383       real(kind=8),external :: ufparm
17384       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
17385 !     if (jjj.gt.0) then
17386 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
17387 !     endif
17388       nfl=nf
17389       icg=mod(nf,2)+1
17390 !d      print *,'func',nf,nfl,icg
17391       call var_to_geom(n,x)
17392       call zerograd
17393       call chainbuild
17394 !d    write (iout,*) 'ETOTAL called from FUNC'
17395       call etotal(energia)
17396       call sum_gradient
17397       f=energia(0)
17398 !     if (jjj.gt.0) then
17399 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
17400 !       write (iout,*) 'f=',etot
17401 !       jjj=0
17402 !     endif
17403       return
17404       end subroutine func
17405 !-----------------------------------------------------------------------------
17406       subroutine cartgrad
17407 !      implicit real*8 (a-h,o-z)
17408 !      include 'DIMENSIONS'
17409       use energy_data
17410       use MD_data, only: totT,usampl,eq_time
17411 #ifdef MPI
17412       include 'mpif.h'
17413 #endif
17414 !      include 'COMMON.CHAIN'
17415 !      include 'COMMON.DERIV'
17416 !      include 'COMMON.VAR'
17417 !      include 'COMMON.INTERACT'
17418 !      include 'COMMON.FFIELD'
17419 !      include 'COMMON.MD'
17420 !      include 'COMMON.IOUNITS'
17421 !      include 'COMMON.TIME1'
17422 !
17423       integer :: i,j
17424       real(kind=8) :: time00,time01
17425
17426 ! This subrouting calculates total Cartesian coordinate gradient.
17427 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
17428 !
17429 !#define DEBUG
17430 #ifdef TIMINGtime01
17431       time00=MPI_Wtime()
17432 #endif
17433       icg=1
17434       call sum_gradient
17435 #ifdef TIMING
17436 #endif
17437 !#define DEBUG
17438 !el      write (iout,*) "After sum_gradient"
17439 !#ifdef DEBUG
17440 !      write (iout,*) "After sum_gradient"
17441 !      do i=1,nres-1
17442 !        write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
17443 !        write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
17444 !      enddo
17445 !#endif
17446 !#undef DEBUG
17447 ! If performing constraint dynamics, add the gradients of the constraint energy
17448       if(usampl.and.totT.gt.eq_time) then
17449          do i=1,nct
17450            do j=1,3
17451              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
17452              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
17453            enddo
17454          enddo
17455          do i=1,nres-3
17456            gloc(i,icg)=gloc(i,icg)+dugamma(i)
17457          enddo
17458          do i=1,nres-2
17459            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
17460          enddo
17461       endif
17462 !elwrite (iout,*) "After sum_gradient"
17463 #ifdef TIMING
17464       time01=MPI_Wtime()
17465 #endif
17466       call intcartderiv
17467 !elwrite (iout,*) "After sum_gradient"
17468 #ifdef TIMING
17469       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
17470 #endif
17471 !     call checkintcartgrad
17472 !     write(iout,*) 'calling int_to_cart'
17473 !#define DEBUG
17474 #ifdef DEBUG
17475       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
17476 #endif
17477       do i=0,nct
17478         do j=1,3
17479           gcart(j,i)=gradc(j,i,icg)
17480           gxcart(j,i)=gradx(j,i,icg)
17481 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
17482         enddo
17483 #ifdef DEBUG
17484         write (iout,'(i5,2(3f10.5,5x),4f10.5)') i,(gcart(j,i),j=1,3),&
17485           (gxcart(j,i),j=1,3),gloc(i,icg),(gloc_sc(j,i,icg),j=1,3)
17486 #endif
17487       enddo
17488 #ifdef TIMING
17489       time01=MPI_Wtime()
17490 #endif
17491 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17492       call int_to_cart
17493 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17494
17495 #ifdef TIMING
17496             time_inttocart=time_inttocart+MPI_Wtime()-time01
17497 #endif
17498 #ifdef DEBUG
17499             write (iout,*) "gcart and gxcart after int_to_cart"
17500             do i=0,nres-1
17501             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
17502             (gxcart(j,i),j=1,3)
17503             enddo
17504 #endif
17505 !#undef DEBUG
17506 #ifdef CARGRAD
17507 #ifdef DEBUG
17508             write (iout,*) "CARGRAD"
17509 #endif
17510             do i=nres,0,-1
17511             do j=1,3
17512               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17513       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17514             enddo
17515       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
17516       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
17517             enddo
17518       ! Correction: dummy residues
17519             if (nnt.gt.1) then
17520               do j=1,3
17521       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
17522             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
17523             enddo
17524           endif
17525           if (nct.lt.nres) then
17526             do j=1,3
17527       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
17528             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
17529             enddo
17530           endif
17531 #endif
17532 #ifdef TIMING
17533           time_cartgrad=time_cartgrad+MPI_Wtime()-time00
17534 #endif
17535 !#undef DEBUG
17536           return
17537           end subroutine cartgrad
17538       !-----------------------------------------------------------------------------
17539           subroutine zerograd
17540       !      implicit real*8 (a-h,o-z)
17541       !      include 'DIMENSIONS'
17542       !      include 'COMMON.DERIV'
17543       !      include 'COMMON.CHAIN'
17544       !      include 'COMMON.VAR'
17545       !      include 'COMMON.MD'
17546       !      include 'COMMON.SCCOR'
17547       !
17548       !el local variables
17549           integer :: i,j,intertyp,k
17550       ! Initialize Cartesian-coordinate gradient
17551       !
17552       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
17553       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
17554
17555       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
17556       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
17557       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
17558       !      allocate(gradcorr_long(3,nres))
17559       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
17560       !      allocate(gcorr6_turn_long(3,nres))
17561       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
17562
17563       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
17564
17565       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
17566       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
17567
17568       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
17569       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
17570
17571       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
17572       !      allocate(gscloc(3,nres)) !(3,maxres)
17573       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
17574
17575
17576
17577       !      common /deriv_scloc/
17578       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
17579       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
17580       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
17581       !      common /mpgrad/
17582       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
17583
17584
17585
17586       !          gradc(j,i,icg)=0.0d0
17587       !          gradx(j,i,icg)=0.0d0
17588
17589       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
17590       !elwrite(iout,*) "icg",icg
17591           do i=-1,nres
17592           do j=1,3
17593             gvdwx(j,i)=0.0D0
17594             gradx_scp(j,i)=0.0D0
17595             gvdwc(j,i)=0.0D0
17596             gvdwc_scp(j,i)=0.0D0
17597             gvdwc_scpp(j,i)=0.0d0
17598             gelc(j,i)=0.0D0
17599             gelc_long(j,i)=0.0D0
17600             gradb(j,i)=0.0d0
17601             gradbx(j,i)=0.0d0
17602             gvdwpp(j,i)=0.0d0
17603             gel_loc(j,i)=0.0d0
17604             gel_loc_long(j,i)=0.0d0
17605             ghpbc(j,i)=0.0D0
17606             ghpbx(j,i)=0.0D0
17607             gcorr3_turn(j,i)=0.0d0
17608             gcorr4_turn(j,i)=0.0d0
17609             gradcorr(j,i)=0.0d0
17610             gradcorr_long(j,i)=0.0d0
17611             gradcorr5_long(j,i)=0.0d0
17612             gradcorr6_long(j,i)=0.0d0
17613             gcorr6_turn_long(j,i)=0.0d0
17614             gradcorr5(j,i)=0.0d0
17615             gradcorr6(j,i)=0.0d0
17616             gcorr6_turn(j,i)=0.0d0
17617             gsccorc(j,i)=0.0d0
17618             gsccorx(j,i)=0.0d0
17619             gradc(j,i,icg)=0.0d0
17620             gradx(j,i,icg)=0.0d0
17621             gscloc(j,i)=0.0d0
17622             gsclocx(j,i)=0.0d0
17623             gliptran(j,i)=0.0d0
17624             gliptranx(j,i)=0.0d0
17625             gliptranc(j,i)=0.0d0
17626             gshieldx(j,i)=0.0d0
17627             gshieldc(j,i)=0.0d0
17628             gshieldc_loc(j,i)=0.0d0
17629             gshieldx_ec(j,i)=0.0d0
17630             gshieldc_ec(j,i)=0.0d0
17631             gshieldc_loc_ec(j,i)=0.0d0
17632             gshieldx_t3(j,i)=0.0d0
17633             gshieldc_t3(j,i)=0.0d0
17634             gshieldc_loc_t3(j,i)=0.0d0
17635             gshieldx_t4(j,i)=0.0d0
17636             gshieldc_t4(j,i)=0.0d0
17637             gshieldc_loc_t4(j,i)=0.0d0
17638             gshieldx_ll(j,i)=0.0d0
17639             gshieldc_ll(j,i)=0.0d0
17640             gshieldc_loc_ll(j,i)=0.0d0
17641             gg_tube(j,i)=0.0d0
17642             gg_tube_sc(j,i)=0.0d0
17643             gradafm(j,i)=0.0d0
17644             gradb_nucl(j,i)=0.0d0
17645             gradbx_nucl(j,i)=0.0d0
17646             gvdwpp_nucl(j,i)=0.0d0
17647             gvdwpp(j,i)=0.0d0
17648             gelpp(j,i)=0.0d0
17649             gvdwpsb(j,i)=0.0d0
17650             gvdwpsb1(j,i)=0.0d0
17651             gvdwsbc(j,i)=0.0d0
17652             gvdwsbx(j,i)=0.0d0
17653             gelsbc(j,i)=0.0d0
17654             gradcorr_nucl(j,i)=0.0d0
17655             gradcorr3_nucl(j,i)=0.0d0
17656             gradxorr_nucl(j,i)=0.0d0
17657             gradxorr3_nucl(j,i)=0.0d0
17658             gelsbx(j,i)=0.0d0
17659             gsbloc(j,i)=0.0d0
17660             gsblocx(j,i)=0.0d0
17661             gradpepcat(j,i)=0.0d0
17662             gradpepcatx(j,i)=0.0d0
17663             gradcatcat(j,i)=0.0d0
17664             gvdwx_scbase(j,i)=0.0d0
17665             gvdwc_scbase(j,i)=0.0d0
17666             gvdwx_pepbase(j,i)=0.0d0
17667             gvdwc_pepbase(j,i)=0.0d0
17668             gvdwx_scpho(j,i)=0.0d0
17669             gvdwc_scpho(j,i)=0.0d0
17670             gvdwc_peppho(j,i)=0.0d0
17671             gradnuclcatx(j,i)=0.0d0
17672             gradnuclcat(j,i)=0.0d0
17673             duscdiff(j,i)=0.0d0
17674             duscdiffx(j,i)=0.0d0
17675           enddo
17676            enddo
17677           do i=0,nres
17678           do j=1,3
17679             do intertyp=1,3
17680              gloc_sc(intertyp,i,icg)=0.0d0
17681             enddo
17682           enddo
17683           enddo
17684           do i=1,nres
17685            do j=1,maxcontsshi
17686            shield_list(j,i)=0
17687           do k=1,3
17688       !C           print *,i,j,k
17689              grad_shield_side(k,j,i)=0.0d0
17690              grad_shield_loc(k,j,i)=0.0d0
17691            enddo
17692            enddo
17693            ishield_list(i)=0
17694           enddo
17695
17696       !
17697       ! Initialize the gradient of local energy terms.
17698       !
17699       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
17700       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
17701       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
17702       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
17703       !      allocate(gel_loc_turn3(nres))
17704       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
17705       !      allocate(gsccor_loc(nres))      !(maxres)
17706
17707           do i=1,4*nres
17708           gloc(i,icg)=0.0D0
17709           enddo
17710           do i=1,nres
17711           gel_loc_loc(i)=0.0d0
17712           gcorr_loc(i)=0.0d0
17713           g_corr5_loc(i)=0.0d0
17714           g_corr6_loc(i)=0.0d0
17715           gel_loc_turn3(i)=0.0d0
17716           gel_loc_turn4(i)=0.0d0
17717           gel_loc_turn6(i)=0.0d0
17718           gsccor_loc(i)=0.0d0
17719           enddo
17720       ! initialize gcart and gxcart
17721       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
17722           do i=0,nres
17723           do j=1,3
17724             gcart(j,i)=0.0d0
17725             gxcart(j,i)=0.0d0
17726           enddo
17727           enddo
17728           return
17729           end subroutine zerograd
17730       !-----------------------------------------------------------------------------
17731           real(kind=8) function fdum()
17732           fdum=0.0D0
17733           return
17734           end function fdum
17735       !-----------------------------------------------------------------------------
17736       ! intcartderiv.F
17737       !-----------------------------------------------------------------------------
17738           subroutine intcartderiv
17739       !      implicit real*8 (a-h,o-z)
17740       !      include 'DIMENSIONS'
17741 #ifdef MPI
17742           include 'mpif.h'
17743 #endif
17744       !      include 'COMMON.SETUP'
17745       !      include 'COMMON.CHAIN'
17746       !      include 'COMMON.VAR'
17747       !      include 'COMMON.GEO'
17748       !      include 'COMMON.INTERACT'
17749       !      include 'COMMON.DERIV'
17750       !      include 'COMMON.IOUNITS'
17751       !      include 'COMMON.LOCAL'
17752       !      include 'COMMON.SCCOR'
17753           real(kind=8) :: pi4,pi34
17754           real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
17755           real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
17756                   dcosomega,dsinomega !(3,3,maxres)
17757           real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
17758
17759           integer :: i,j,k
17760           real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
17761                 fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
17762                 fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
17763                 fac17,coso_inv,fac10,fac11,fac12,fac13,fac14,IERROR
17764           integer :: nres2
17765           nres2=2*nres
17766
17767       !el from module energy-------------
17768       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
17769       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
17770       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
17771
17772       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
17773       !el      allocate(dsintau(3,3,3,0:nres2))
17774       !el      allocate(dtauangle(3,3,3,0:nres2))
17775       !el      allocate(domicron(3,2,2,0:nres2))
17776       !el      allocate(dcosomicron(3,2,2,0:nres2))
17777
17778
17779
17780 #if defined(MPI) && defined(PARINTDER)
17781           if (nfgtasks.gt.1 .and. me.eq.king) &
17782           call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
17783 #endif
17784           pi4 = 0.5d0*pipol
17785           pi34 = 3*pi4
17786
17787       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
17788       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
17789
17790       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
17791           do i=1,nres
17792           do j=1,3
17793             dtheta(j,1,i)=0.0d0
17794             dtheta(j,2,i)=0.0d0
17795             dphi(j,1,i)=0.0d0
17796             dphi(j,2,i)=0.0d0
17797             dphi(j,3,i)=0.0d0
17798             dcosomicron(j,1,1,i)=0.0d0
17799             dcosomicron(j,1,2,i)=0.0d0
17800             dcosomicron(j,2,1,i)=0.0d0
17801             dcosomicron(j,2,2,i)=0.0d0
17802           enddo
17803           enddo
17804       ! Derivatives of theta's
17805 #if defined(MPI) && defined(PARINTDER)
17806       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17807           do i=max0(ithet_start-1,3),ithet_end
17808 #else
17809           do i=3,nres
17810 #endif
17811           cost=dcos(theta(i))
17812           sint=sqrt(1-cost*cost)
17813           do j=1,3
17814             dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
17815             vbld(i-1)
17816             if (((itype(i-1,1).ne.ntyp1).and.(sint.ne.0.0d0))) &
17817              dtheta(j,1,i)=-dcostheta(j,1,i)/sint
17818             dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
17819             vbld(i)
17820             if ((itype(i-1,1).ne.ntyp1).and.(sint.ne.0.0d0))&
17821              dtheta(j,2,i)=-dcostheta(j,2,i)/sint
17822           enddo
17823           enddo
17824 #if defined(MPI) && defined(PARINTDER)
17825       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17826           do i=max0(ithet_start-1,3),ithet_end
17827 #else
17828           do i=3,nres
17829 #endif
17830           if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1).and.molnum(i).ne.5) then
17831           cost1=dcos(omicron(1,i))
17832           sint1=sqrt(1-cost1*cost1)
17833           cost2=dcos(omicron(2,i))
17834           sint2=sqrt(1-cost2*cost2)
17835            do j=1,3
17836       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
17837             dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
17838             cost1*dc_norm(j,i-2))/ &
17839             vbld(i-1)
17840             domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
17841             dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
17842             +cost1*(dc_norm(j,i-1+nres)))/ &
17843             vbld(i-1+nres)
17844             domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
17845       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
17846       !C Looks messy but better than if in loop
17847             dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
17848             +cost2*dc_norm(j,i-1))/ &
17849             vbld(i)
17850             domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
17851             dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
17852              +cost2*(-dc_norm(j,i-1+nres)))/ &
17853             vbld(i-1+nres)
17854       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
17855             domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
17856           enddo
17857            endif
17858           enddo
17859       !elwrite(iout,*) "after vbld write"
17860       ! Derivatives of phi:
17861       ! If phi is 0 or 180 degrees, then the formulas
17862       ! have to be derived by power series expansion of the
17863       ! conventional formulas around 0 and 180.
17864 #ifdef PARINTDER
17865           do i=iphi1_start,iphi1_end
17866 #else
17867           do i=4,nres
17868 #endif
17869       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
17870       ! the conventional case
17871           sint=dsin(theta(i))
17872           sint1=dsin(theta(i-1))
17873           sing=dsin(phi(i))
17874           cost=dcos(theta(i))
17875           cost1=dcos(theta(i-1))
17876           cosg=dcos(phi(i))
17877           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
17878           if ((sint*sint1).eq.0.0d0) then
17879           fac0=0.0d0
17880           else
17881           fac0=1.0d0/(sint1*sint)
17882           endif
17883           fac1=cost*fac0
17884           fac2=cost1*fac0
17885           if (sint1.ne.0.0d0) then
17886           fac3=cosg*cost1/(sint1*sint1)
17887           else
17888           fac3=0.0d0
17889           endif
17890           if (sint.ne.0.0d0) then
17891           fac4=cosg*cost/(sint*sint)
17892           else
17893           fac4=0.0d0
17894           endif
17895       !    Obtaining the gamma derivatives from sine derivative
17896            if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
17897              phi(i).gt.pi34.and.phi(i).le.pi.or. &
17898              phi(i).ge.-pi.and.phi(i).le.-pi34) then
17899            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17900            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
17901            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17902            do j=1,3
17903             if (sint.ne.0.0d0) then
17904             ctgt=cost/sint
17905             else
17906             ctgt=0.0d0
17907             endif
17908             if (sint1.ne.0.0d0) then
17909             ctgt1=cost1/sint1
17910             else
17911             ctgt1=0.0d0
17912             endif
17913             cosg_inv=1.0d0/cosg
17914             if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17915             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17916               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
17917             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
17918             dsinphi(j,2,i)= &
17919               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
17920               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17921             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
17922             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
17923               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17924       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17925             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
17926             endif
17927 !             write(iout,*) "just after,close to pi",dphi(j,3,i),&
17928 !              sing*(ctgt1*dtheta(j,2,i-1)),ctgt*dtheta(j,1,i), &
17929 !              (fac0*vp2(j)+sing*dc_norm(j,i-2)),vbld_inv(i-1)
17930
17931       ! Bug fixed 3/24/05 (AL)
17932            enddo
17933       !   Obtaining the gamma derivatives from cosine derivative
17934           else
17935              do j=1,3
17936              if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17937              dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17938              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17939              dc_norm(j,i-3))/vbld(i-2)
17940              dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
17941              dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17942              dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17943              dcostheta(j,1,i)
17944              dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
17945              dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17946              dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17947              dc_norm(j,i-1))/vbld(i)
17948              dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
17949 !#define DEBUG
17950 #ifdef DEBUG
17951              write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
17952 #endif
17953 !#undef DEBUG
17954              endif
17955            enddo
17956           endif
17957           enddo
17958       !alculate derivative of Tauangle
17959 #ifdef PARINTDER
17960           do i=itau_start,itau_end
17961 #else
17962           do i=3,nres
17963       !elwrite(iout,*) " vecpr",i,nres
17964 #endif
17965            if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17966       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
17967       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
17968       !c dtauangle(j,intertyp,dervityp,residue number)
17969       !c INTERTYP=1 SC...Ca...Ca..Ca
17970       ! the conventional case
17971           sint=dsin(theta(i))
17972           sint1=dsin(omicron(2,i-1))
17973           sing=dsin(tauangle(1,i))
17974           cost=dcos(theta(i))
17975           cost1=dcos(omicron(2,i-1))
17976           cosg=dcos(tauangle(1,i))
17977       !elwrite(iout,*) " vecpr5",i,nres
17978           do j=1,3
17979       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
17980       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
17981           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17982       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
17983           enddo
17984           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
17985       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac
17986         if ((sint*sint1).eq.0.0d0) then
17987           fac0=0.0d0
17988           else
17989           fac0=1.0d0/(sint1*sint)
17990           endif
17991           fac1=cost*fac0
17992           fac2=cost1*fac0
17993           if (sint1.ne.0.0d0) then
17994           fac3=cosg*cost1/(sint1*sint1)
17995           else
17996           fac3=0.0d0
17997           endif
17998           if (sint.ne.0.0d0) then
17999           fac4=cosg*cost/(sint*sint)
18000           else
18001           fac4=0.0d0
18002           endif
18003
18004       !    Obtaining the gamma derivatives from sine derivative
18005            if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
18006              tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
18007              tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
18008            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
18009            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
18010            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
18011           do j=1,3
18012             ctgt=cost/sint
18013             ctgt1=cost1/sint1
18014             cosg_inv=1.0d0/cosg
18015             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
18016            -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
18017            *vbld_inv(i-2+nres)
18018             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
18019             dsintau(j,1,2,i)= &
18020               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
18021               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18022       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
18023             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
18024       ! Bug fixed 3/24/05 (AL)
18025             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
18026               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
18027       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
18028             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
18029            enddo
18030       !   Obtaining the gamma derivatives from cosine derivative
18031           else
18032              do j=1,3
18033              dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
18034              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
18035              (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
18036              dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
18037              dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
18038              dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
18039              dcostheta(j,1,i)
18040              dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
18041              dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
18042              dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
18043              dc_norm(j,i-1))/vbld(i)
18044              dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
18045       !         write (iout,*) "else",i
18046            enddo
18047           endif
18048       !        do k=1,3
18049       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
18050       !        enddo
18051           enddo
18052       !C Second case Ca...Ca...Ca...SC
18053 #ifdef PARINTDER
18054           do i=itau_start,itau_end
18055 #else
18056           do i=4,nres
18057 #endif
18058            if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
18059             (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
18060       ! the conventional case
18061           sint=dsin(omicron(1,i))
18062           sint1=dsin(theta(i-1))
18063           sing=dsin(tauangle(2,i))
18064           cost=dcos(omicron(1,i))
18065           cost1=dcos(theta(i-1))
18066           cosg=dcos(tauangle(2,i))
18067       !        do j=1,3
18068       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
18069       !        enddo
18070           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
18071         if ((sint*sint1).eq.0.0d0) then
18072           fac0=0.0d0
18073           else
18074           fac0=1.0d0/(sint1*sint)
18075           endif
18076           fac1=cost*fac0
18077           fac2=cost1*fac0
18078           if (sint1.ne.0.0d0) then
18079           fac3=cosg*cost1/(sint1*sint1)
18080           else
18081           fac3=0.0d0
18082           endif
18083           if (sint.ne.0.0d0) then
18084           fac4=cosg*cost/(sint*sint)
18085           else
18086           fac4=0.0d0
18087           endif
18088       !    Obtaining the gamma derivatives from sine derivative
18089            if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
18090              tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
18091              tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
18092            call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
18093            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
18094            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
18095           do j=1,3
18096             ctgt=cost/sint
18097             ctgt1=cost1/sint1
18098             cosg_inv=1.0d0/cosg
18099             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
18100               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
18101       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
18102       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
18103             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
18104             dsintau(j,2,2,i)= &
18105               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
18106               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18107       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
18108       !     & sing*ctgt*domicron(j,1,2,i),
18109       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18110             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
18111       ! Bug fixed 3/24/05 (AL)
18112             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
18113              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
18114       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
18115             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
18116            enddo
18117       !   Obtaining the gamma derivatives from cosine derivative
18118           else
18119              do j=1,3
18120              dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
18121              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
18122              dc_norm(j,i-3))/vbld(i-2)
18123              dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
18124              dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
18125              dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
18126              dcosomicron(j,1,1,i)
18127              dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
18128              dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
18129              dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
18130              dc_norm(j,i-1+nres))/vbld(i-1+nres)
18131              dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
18132       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
18133            enddo
18134           endif
18135           enddo
18136
18137       !CC third case SC...Ca...Ca...SC
18138 #ifdef PARINTDER
18139
18140           do i=itau_start,itau_end
18141 #else
18142           do i=3,nres
18143 #endif
18144       ! the conventional case
18145           if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
18146           (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
18147           sint=dsin(omicron(1,i))
18148           sint1=dsin(omicron(2,i-1))
18149           sing=dsin(tauangle(3,i))
18150           cost=dcos(omicron(1,i))
18151           cost1=dcos(omicron(2,i-1))
18152           cosg=dcos(tauangle(3,i))
18153           do j=1,3
18154           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
18155       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
18156           enddo
18157           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
18158         if ((sint*sint1).eq.0.0d0) then
18159           fac0=0.0d0
18160           else
18161           fac0=1.0d0/(sint1*sint)
18162           endif
18163           fac1=cost*fac0
18164           fac2=cost1*fac0
18165           if (sint1.ne.0.0d0) then
18166           fac3=cosg*cost1/(sint1*sint1)
18167           else
18168           fac3=0.0d0
18169           endif
18170           if (sint.ne.0.0d0) then
18171           fac4=cosg*cost/(sint*sint)
18172           else
18173           fac4=0.0d0
18174           endif
18175       !    Obtaining the gamma derivatives from sine derivative
18176            if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
18177              tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
18178              tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
18179            call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
18180            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
18181            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
18182           do j=1,3
18183             ctgt=cost/sint
18184             ctgt1=cost1/sint1
18185             cosg_inv=1.0d0/cosg
18186             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
18187               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
18188               *vbld_inv(i-2+nres)
18189             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
18190             dsintau(j,3,2,i)= &
18191               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
18192               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18193             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
18194       ! Bug fixed 3/24/05 (AL)
18195             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
18196               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
18197               *vbld_inv(i-1+nres)
18198       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
18199             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
18200            enddo
18201       !   Obtaining the gamma derivatives from cosine derivative
18202           else
18203              do j=1,3
18204              dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
18205              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
18206              dc_norm2(j,i-2+nres))/vbld(i-2+nres)
18207              dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
18208              dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
18209              dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
18210              dcosomicron(j,1,1,i)
18211              dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
18212              dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
18213              dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
18214              dc_norm(j,i-1+nres))/vbld(i-1+nres)
18215              dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
18216       !          write(iout,*) "else",i
18217            enddo
18218           endif
18219           enddo
18220
18221 #ifdef CRYST_SC
18222       !   Derivatives of side-chain angles alpha and omega
18223 #if defined(MPI) && defined(PARINTDER)
18224           do i=ibond_start,ibond_end
18225 #else
18226           do i=2,nres-1
18227 #endif
18228             if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
18229              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
18230              fac6=fac5/vbld(i)
18231              fac7=fac5*fac5
18232              fac8=fac5/vbld(i+1)
18233              fac9=fac5/vbld(i+nres)
18234              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
18235              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
18236              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
18237              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
18238              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
18239              sina=sqrt(1-cosa*cosa)
18240              sino=dsin(omeg(i))
18241       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
18242              do j=1,3
18243               dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
18244               dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
18245               dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
18246               dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
18247               scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
18248               dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
18249               dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
18250               dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
18251               vbld(i+nres))
18252               dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
18253             enddo
18254       ! obtaining the derivatives of omega from sines
18255             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
18256                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
18257                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
18258                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
18259                dsin(theta(i+1)))
18260                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
18261                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
18262                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
18263                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
18264                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
18265                coso_inv=1.0d0/dcos(omeg(i))
18266                do j=1,3
18267                dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
18268                +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
18269                (sino*dc_norm(j,i-1))/vbld(i)
18270                domega(j,1,i)=coso_inv*dsinomega(j,1,i)
18271                dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
18272                +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
18273                -sino*dc_norm(j,i)/vbld(i+1)
18274                domega(j,2,i)=coso_inv*dsinomega(j,2,i)
18275                dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
18276                fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
18277                vbld(i+nres)
18278                domega(j,3,i)=coso_inv*dsinomega(j,3,i)
18279               enddo
18280              else
18281       !   obtaining the derivatives of omega from cosines
18282              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
18283              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
18284              fac12=fac10*sina
18285              fac13=fac12*fac12
18286              fac14=sina*sina
18287              do j=1,3
18288               dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
18289               dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
18290               (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
18291               fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
18292               domega(j,1,i)=-1/sino*dcosomega(j,1,i)
18293               dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
18294               dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
18295               dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
18296               (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
18297               dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
18298               domega(j,2,i)=-1/sino*dcosomega(j,2,i)
18299               dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
18300               scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
18301               (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
18302               domega(j,3,i)=-1/sino*dcosomega(j,3,i)
18303             enddo
18304             endif
18305            else
18306              do j=1,3
18307              do k=1,3
18308                dalpha(k,j,i)=0.0d0
18309                domega(k,j,i)=0.0d0
18310              enddo
18311              enddo
18312            endif
18313            enddo
18314 #endif
18315 #if defined(MPI) && defined(PARINTDER)
18316           if (nfgtasks.gt.1) then
18317 #ifdef DEBUG
18318       !d      write (iout,*) "Gather dtheta"
18319       !d      call flush(iout)
18320           write (iout,*) "dtheta before gather"
18321           do i=1,nres
18322           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
18323           enddo
18324 #endif
18325           call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
18326           MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
18327           king,FG_COMM,IERROR)
18328 !#define DEBUG
18329 #ifdef DEBUG
18330       !d      write (iout,*) "Gather dphi"
18331       !d      call flush(iout)
18332           write (iout,*) "dphi before gather"
18333           do i=1,nres
18334           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
18335           enddo
18336 #endif
18337 !#undef DEBUG
18338           call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
18339           MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
18340           king,FG_COMM,IERROR)
18341       !d      write (iout,*) "Gather dalpha"
18342       !d      call flush(iout)
18343 #ifdef CRYST_SC
18344           call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
18345           MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
18346           king,FG_COMM,IERROR)
18347       !d      write (iout,*) "Gather domega"
18348       !d      call flush(iout)
18349           call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
18350           MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
18351           king,FG_COMM,IERROR)
18352 #endif
18353           endif
18354 #endif
18355 !#define DEBUG
18356 #ifdef DEBUG
18357           write (iout,*) "dtheta after gather"
18358           do i=1,nres
18359           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
18360           enddo
18361           write (iout,*) "dphi after gather"
18362           do i=1,nres
18363           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
18364           enddo
18365           write (iout,*) "dalpha after gather"
18366           do i=1,nres
18367           write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
18368           enddo
18369           write (iout,*) "domega after gather"
18370           do i=1,nres
18371           write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
18372           enddo
18373 #endif
18374 !#undef DEBUG
18375           return
18376           end subroutine intcartderiv
18377       !-----------------------------------------------------------------------------
18378           subroutine checkintcartgrad
18379       !      implicit real*8 (a-h,o-z)
18380       !      include 'DIMENSIONS'
18381 #ifdef MPI
18382           include 'mpif.h'
18383 #endif
18384       !      include 'COMMON.CHAIN'
18385       !      include 'COMMON.VAR'
18386       !      include 'COMMON.GEO'
18387       !      include 'COMMON.INTERACT'
18388       !      include 'COMMON.DERIV'
18389       !      include 'COMMON.IOUNITS'
18390       !      include 'COMMON.SETUP'
18391           real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
18392           real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
18393           real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
18394           real(kind=8),dimension(3) :: dc_norm_s
18395           real(kind=8) :: aincr=1.0d-5
18396           integer :: i,j
18397           real(kind=8) :: dcji
18398           do i=1,nres
18399           phi_s(i)=phi(i)
18400           theta_s(i)=theta(i)
18401           alph_s(i)=alph(i)
18402           omeg_s(i)=omeg(i)
18403           enddo
18404       ! Check theta gradient
18405           write (iout,*) &
18406            "Analytical (upper) and numerical (lower) gradient of theta"
18407           write (iout,*)
18408           do i=3,nres
18409           do j=1,3
18410             dcji=dc(j,i-2)
18411             dc(j,i-2)=dcji+aincr
18412             call chainbuild_cart
18413             call int_from_cart1(.false.)
18414         dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
18415         dc(j,i-2)=dcji
18416         dcji=dc(j,i-1)
18417         dc(j,i-1)=dc(j,i-1)+aincr
18418         call chainbuild_cart
18419         dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
18420         dc(j,i-1)=dcji
18421       enddo
18422 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
18423 !el          (dtheta(j,2,i),j=1,3)
18424 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
18425 !el          (dthetanum(j,2,i),j=1,3)
18426 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
18427 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
18428 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
18429 !el        write (iout,*)
18430       enddo
18431 ! Check gamma gradient
18432       write (iout,*) &
18433        "Analytical (upper) and numerical (lower) gradient of gamma"
18434       do i=4,nres
18435       do j=1,3
18436         dcji=dc(j,i-3)
18437         dc(j,i-3)=dcji+aincr
18438         call chainbuild_cart
18439         dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
18440             dc(j,i-3)=dcji
18441         dcji=dc(j,i-2)
18442         dc(j,i-2)=dcji+aincr
18443         call chainbuild_cart
18444         dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
18445         dc(j,i-2)=dcji
18446         dcji=dc(j,i-1)
18447         dc(j,i-1)=dc(j,i-1)+aincr
18448         call chainbuild_cart
18449         dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
18450         dc(j,i-1)=dcji
18451       enddo
18452 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
18453 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
18454 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
18455 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
18456 !el        write (iout,'(5x,3(3f10.5,5x))') &
18457 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
18458 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
18459 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
18460 !el        write (iout,*)
18461       enddo
18462 ! Check alpha gradient
18463       write (iout,*) &
18464        "Analytical (upper) and numerical (lower) gradient of alpha"
18465       do i=2,nres-1
18466        if(itype(i,1).ne.10) then
18467              do j=1,3
18468               dcji=dc(j,i-1)
18469                dc(j,i-1)=dcji+aincr
18470             call chainbuild_cart
18471             dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
18472              /aincr
18473               dc(j,i-1)=dcji
18474             dcji=dc(j,i)
18475             dc(j,i)=dcji+aincr
18476             call chainbuild_cart
18477             dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
18478              /aincr
18479             dc(j,i)=dcji
18480             dcji=dc(j,i+nres)
18481             dc(j,i+nres)=dc(j,i+nres)+aincr
18482             call chainbuild_cart
18483             dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
18484              /aincr
18485            dc(j,i+nres)=dcji
18486           enddo
18487         endif
18488 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
18489 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
18490 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
18491 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
18492 !el        write (iout,'(5x,3(3f10.5,5x))') &
18493 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
18494 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
18495 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
18496 !el        write (iout,*)
18497       enddo
18498 !     Check omega gradient
18499       write (iout,*) &
18500        "Analytical (upper) and numerical (lower) gradient of omega"
18501       do i=2,nres-1
18502        if(itype(i,1).ne.10) then
18503              do j=1,3
18504               dcji=dc(j,i-1)
18505                dc(j,i-1)=dcji+aincr
18506             call chainbuild_cart
18507             domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
18508              /aincr
18509               dc(j,i-1)=dcji
18510             dcji=dc(j,i)
18511             dc(j,i)=dcji+aincr
18512             call chainbuild_cart
18513             domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
18514              /aincr
18515             dc(j,i)=dcji
18516             dcji=dc(j,i+nres)
18517             dc(j,i+nres)=dc(j,i+nres)+aincr
18518             call chainbuild_cart
18519             domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
18520              /aincr
18521            dc(j,i+nres)=dcji
18522           enddo
18523         endif
18524 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
18525 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
18526 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
18527 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
18528 !el        write (iout,'(5x,3(3f10.5,5x))') &
18529 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
18530 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
18531 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
18532 !el        write (iout,*)
18533       enddo
18534       return
18535       end subroutine checkintcartgrad
18536 !-----------------------------------------------------------------------------
18537 ! q_measure.F
18538 !-----------------------------------------------------------------------------
18539       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
18540 !      implicit real*8 (a-h,o-z)
18541 !      include 'DIMENSIONS'
18542 !      include 'COMMON.IOUNITS'
18543 !      include 'COMMON.CHAIN'
18544 !      include 'COMMON.INTERACT'
18545 !      include 'COMMON.VAR'
18546       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
18547       integer :: kkk,nsep=3
18548       real(kind=8) :: qm      !dist,
18549       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
18550       logical :: lprn=.false.
18551       logical :: flag
18552 !      real(kind=8) :: sigm,x
18553
18554 !el      sigm(x)=0.25d0*x     ! local function
18555       qqmax=1.0d10
18556       do kkk=1,nperm
18557       qq = 0.0d0
18558       nl=0
18559        if(flag) then
18560       do il=seg1+nsep,seg2
18561         do jl=seg1,il-nsep
18562           nl=nl+1
18563           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
18564                    (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
18565                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18566           dij=dist(il,jl)
18567           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18568           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18569             nl=nl+1
18570             d0ijCM=dsqrt( &
18571                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18572                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18573                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18574             dijCM=dist(il+nres,jl+nres)
18575             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18576           endif
18577           qq = qq+qqij+qqijCM
18578         enddo
18579       enddo
18580       qq = qq/nl
18581       else
18582       do il=seg1,seg2
18583       if((seg3-il).lt.3) then
18584            secseg=il+3
18585       else
18586            secseg=seg3
18587       endif
18588         do jl=secseg,seg4
18589           nl=nl+1
18590           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18591                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18592                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18593           dij=dist(il,jl)
18594           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18595           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18596             nl=nl+1
18597             d0ijCM=dsqrt( &
18598                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18599                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18600                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18601             dijCM=dist(il+nres,jl+nres)
18602             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18603           endif
18604           qq = qq+qqij+qqijCM
18605         enddo
18606       enddo
18607       qq = qq/nl
18608       endif
18609       if (qqmax.le.qq) qqmax=qq
18610       enddo
18611       qwolynes=1.0d0-qqmax
18612       return
18613       end function qwolynes
18614 !-----------------------------------------------------------------------------
18615       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
18616 !      implicit real*8 (a-h,o-z)
18617 !      include 'DIMENSIONS'
18618 !      include 'COMMON.IOUNITS'
18619 !      include 'COMMON.CHAIN'
18620 !      include 'COMMON.INTERACT'
18621 !      include 'COMMON.VAR'
18622 !      include 'COMMON.MD'
18623       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
18624       integer :: nsep=3, kkk
18625 !el      real(kind=8) :: dist
18626       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
18627       logical :: lprn=.false.
18628       logical :: flag
18629       real(kind=8) :: sim,dd0,fac,ddqij
18630 !el      sigm(x)=0.25d0*x           ! local function
18631       do kkk=1,nperm
18632       do i=0,nres
18633       do j=1,3
18634         dqwol(j,i)=0.0d0
18635         dxqwol(j,i)=0.0d0
18636       enddo
18637       enddo
18638       nl=0
18639        if(flag) then
18640       do il=seg1+nsep,seg2
18641         do jl=seg1,il-nsep
18642           nl=nl+1
18643           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18644                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18645                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18646           dij=dist(il,jl)
18647           sim = 1.0d0/sigm(d0ij)
18648           sim = sim*sim
18649           dd0 = dij-d0ij
18650           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18651         do k=1,3
18652             ddqij = (c(k,il)-c(k,jl))*fac
18653             dqwol(k,il)=dqwol(k,il)+ddqij
18654             dqwol(k,jl)=dqwol(k,jl)-ddqij
18655           enddo
18656
18657           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18658             nl=nl+1
18659             d0ijCM=dsqrt( &
18660                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18661                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18662                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18663             dijCM=dist(il+nres,jl+nres)
18664             sim = 1.0d0/sigm(d0ijCM)
18665             sim = sim*sim
18666             dd0=dijCM-d0ijCM
18667             fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18668             do k=1,3
18669             ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18670             dxqwol(k,il)=dxqwol(k,il)+ddqij
18671             dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18672             enddo
18673           endif
18674         enddo
18675       enddo
18676        else
18677       do il=seg1,seg2
18678       if((seg3-il).lt.3) then
18679            secseg=il+3
18680       else
18681            secseg=seg3
18682       endif
18683         do jl=secseg,seg4
18684           nl=nl+1
18685           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18686                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18687                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18688           dij=dist(il,jl)
18689           sim = 1.0d0/sigm(d0ij)
18690           sim = sim*sim
18691           dd0 = dij-d0ij
18692           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18693           do k=1,3
18694             ddqij = (c(k,il)-c(k,jl))*fac
18695             dqwol(k,il)=dqwol(k,il)+ddqij
18696             dqwol(k,jl)=dqwol(k,jl)-ddqij
18697           enddo
18698           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18699             nl=nl+1
18700             d0ijCM=dsqrt( &
18701                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18702                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18703                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18704             dijCM=dist(il+nres,jl+nres)
18705             sim = 1.0d0/sigm(d0ijCM)
18706             sim=sim*sim
18707             dd0 = dijCM-d0ijCM
18708             fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18709             do k=1,3
18710              ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18711              dxqwol(k,il)=dxqwol(k,il)+ddqij
18712              dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18713             enddo
18714           endif
18715         enddo
18716       enddo
18717       endif
18718       enddo
18719        do i=0,nres
18720        do j=1,3
18721          dqwol(j,i)=dqwol(j,i)/nl
18722          dxqwol(j,i)=dxqwol(j,i)/nl
18723        enddo
18724        enddo
18725       return
18726       end subroutine qwolynes_prim
18727 !-----------------------------------------------------------------------------
18728       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
18729 !      implicit real*8 (a-h,o-z)
18730 !      include 'DIMENSIONS'
18731 !      include 'COMMON.IOUNITS'
18732 !      include 'COMMON.CHAIN'
18733 !      include 'COMMON.INTERACT'
18734 !      include 'COMMON.VAR'
18735       integer :: seg1,seg2,seg3,seg4
18736       logical :: flag
18737       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
18738       real(kind=8),dimension(3,0:2*nres) :: cdummy
18739       real(kind=8) :: q1,q2
18740       real(kind=8) :: delta=1.0d-10
18741       integer :: i,j
18742
18743       do i=0,nres
18744       do j=1,3
18745         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18746         cdummy(j,i)=c(j,i)
18747         c(j,i)=c(j,i)+delta
18748         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18749         qwolan(j,i)=(q2-q1)/delta
18750         c(j,i)=cdummy(j,i)
18751       enddo
18752       enddo
18753       do i=0,nres
18754       do j=1,3
18755         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18756         cdummy(j,i+nres)=c(j,i+nres)
18757         c(j,i+nres)=c(j,i+nres)+delta
18758         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18759         qwolxan(j,i)=(q2-q1)/delta
18760         c(j,i+nres)=cdummy(j,i+nres)
18761       enddo
18762       enddo
18763 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
18764 !      do i=0,nct
18765 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
18766 !      enddo
18767 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
18768 !      do i=0,nct
18769 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
18770 !      enddo
18771       return
18772       end subroutine qwol_num
18773 !-----------------------------------------------------------------------------
18774       subroutine EconstrQ
18775 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
18776 !      implicit real*8 (a-h,o-z)
18777 !      include 'DIMENSIONS'
18778 !      include 'COMMON.CONTROL'
18779 !      include 'COMMON.VAR'
18780 !      include 'COMMON.MD'
18781       use MD_data
18782 !#ifndef LANG0
18783 !      include 'COMMON.LANGEVIN'
18784 !#else
18785 !      include 'COMMON.LANGEVIN.lang0'
18786 !#endif
18787 !      include 'COMMON.CHAIN'
18788 !      include 'COMMON.DERIV'
18789 !      include 'COMMON.GEO'
18790 !      include 'COMMON.LOCAL'
18791 !      include 'COMMON.INTERACT'
18792 !      include 'COMMON.IOUNITS'
18793 !      include 'COMMON.NAMES'
18794 !      include 'COMMON.TIME1'
18795       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
18796       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
18797                duconst,duxconst
18798       integer :: kstart,kend,lstart,lend,idummy
18799       real(kind=8) :: delta=1.0d-7
18800       integer :: i,j,k,ii
18801       do i=0,nres
18802        do j=1,3
18803           duconst(j,i)=0.0d0
18804           dudconst(j,i)=0.0d0
18805           duxconst(j,i)=0.0d0
18806           dudxconst(j,i)=0.0d0
18807        enddo
18808       enddo
18809       Uconst=0.0d0
18810       do i=1,nfrag
18811        qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18812          idummy,idummy)
18813        Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
18814 ! Calculating the derivatives of Constraint energy with respect to Q
18815        Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
18816          qinfrag(i,iset))
18817 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
18818 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
18819 !         hmnum=(hm2-hm1)/delta
18820 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
18821 !     &   qinfrag(i,iset))
18822 !         write(iout,*) "harmonicnum frag", hmnum
18823 ! Calculating the derivatives of Q with respect to cartesian coordinates
18824        call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18825         idummy,idummy)
18826 !         write(iout,*) "dqwol "
18827 !         do ii=1,nres
18828 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18829 !         enddo
18830 !         write(iout,*) "dxqwol "
18831 !         do ii=1,nres
18832 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18833 !         enddo
18834 ! Calculating numerical gradients of dU/dQi and dQi/dxi
18835 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
18836 !     &  ,idummy,idummy)
18837 !  The gradients of Uconst in Cs
18838        do ii=0,nres
18839           do j=1,3
18840              duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
18841              dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
18842           enddo
18843        enddo
18844       enddo
18845       do i=1,npair
18846        kstart=ifrag(1,ipair(1,i,iset),iset)
18847        kend=ifrag(2,ipair(1,i,iset),iset)
18848        lstart=ifrag(1,ipair(2,i,iset),iset)
18849        lend=ifrag(2,ipair(2,i,iset),iset)
18850        qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
18851        Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
18852 !  Calculating dU/dQ
18853        Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
18854 !         hm1=harmonic(qpair(i),qinpair(i,iset))
18855 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
18856 !         hmnum=(hm2-hm1)/delta
18857 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
18858 !     &   qinpair(i,iset))
18859 !         write(iout,*) "harmonicnum pair ", hmnum
18860 ! Calculating dQ/dXi
18861        call qwolynes_prim(kstart,kend,.false.,&
18862         lstart,lend)
18863 !         write(iout,*) "dqwol "
18864 !         do ii=1,nres
18865 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18866 !         enddo
18867 !         write(iout,*) "dxqwol "
18868 !         do ii=1,nres
18869 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18870 !        enddo
18871 ! Calculating numerical gradients
18872 !        call qwol_num(kstart,kend,.false.
18873 !     &  ,lstart,lend)
18874 ! The gradients of Uconst in Cs
18875        do ii=0,nres
18876           do j=1,3
18877              duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
18878              dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
18879           enddo
18880        enddo
18881       enddo
18882 !      write(iout,*) "Uconst inside subroutine ", Uconst
18883 ! Transforming the gradients from Cs to dCs for the backbone
18884       do i=0,nres
18885        do j=i+1,nres
18886          do k=1,3
18887            dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
18888          enddo
18889        enddo
18890       enddo
18891 !  Transforming the gradients from Cs to dCs for the side chains
18892       do i=1,nres
18893        do j=1,3
18894          dudxconst(j,i)=duxconst(j,i)
18895        enddo
18896       enddo
18897 !      write(iout,*) "dU/ddc backbone "
18898 !       do ii=0,nres
18899 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
18900 !      enddo
18901 !      write(iout,*) "dU/ddX side chain "
18902 !      do ii=1,nres
18903 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
18904 !      enddo
18905 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
18906 !      call dEconstrQ_num
18907       return
18908       end subroutine EconstrQ
18909 !-----------------------------------------------------------------------------
18910       subroutine dEconstrQ_num
18911 ! Calculating numerical dUconst/ddc and dUconst/ddx
18912 !      implicit real*8 (a-h,o-z)
18913 !      include 'DIMENSIONS'
18914 !      include 'COMMON.CONTROL'
18915 !      include 'COMMON.VAR'
18916 !      include 'COMMON.MD'
18917       use MD_data
18918 !#ifndef LANG0
18919 !      include 'COMMON.LANGEVIN'
18920 !#else
18921 !      include 'COMMON.LANGEVIN.lang0'
18922 !#endif
18923 !      include 'COMMON.CHAIN'
18924 !      include 'COMMON.DERIV'
18925 !      include 'COMMON.GEO'
18926 !      include 'COMMON.LOCAL'
18927 !      include 'COMMON.INTERACT'
18928 !      include 'COMMON.IOUNITS'
18929 !      include 'COMMON.NAMES'
18930 !      include 'COMMON.TIME1'
18931       real(kind=8) :: uzap1,uzap2
18932       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
18933       integer :: kstart,kend,lstart,lend,idummy
18934       real(kind=8) :: delta=1.0d-7
18935 !el local variables
18936       integer :: i,ii,j
18937 !     real(kind=8) ::
18938 !     For the backbone
18939       do i=0,nres-1
18940        do j=1,3
18941           dUcartan(j,i)=0.0d0
18942           cdummy(j,i)=dc(j,i)
18943           dc(j,i)=dc(j,i)+delta
18944           call chainbuild_cart
18945         uzap2=0.0d0
18946           do ii=1,nfrag
18947            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18948             idummy,idummy)
18949              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18950             qinfrag(ii,iset))
18951           enddo
18952           do ii=1,npair
18953              kstart=ifrag(1,ipair(1,ii,iset),iset)
18954              kend=ifrag(2,ipair(1,ii,iset),iset)
18955              lstart=ifrag(1,ipair(2,ii,iset),iset)
18956              lend=ifrag(2,ipair(2,ii,iset),iset)
18957              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18958              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18959              qinpair(ii,iset))
18960           enddo
18961           dc(j,i)=cdummy(j,i)
18962           call chainbuild_cart
18963           uzap1=0.0d0
18964            do ii=1,nfrag
18965            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18966             idummy,idummy)
18967              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18968             qinfrag(ii,iset))
18969           enddo
18970           do ii=1,npair
18971              kstart=ifrag(1,ipair(1,ii,iset),iset)
18972              kend=ifrag(2,ipair(1,ii,iset),iset)
18973              lstart=ifrag(1,ipair(2,ii,iset),iset)
18974              lend=ifrag(2,ipair(2,ii,iset),iset)
18975              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18976              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18977             qinpair(ii,iset))
18978           enddo
18979           ducartan(j,i)=(uzap2-uzap1)/(delta)
18980        enddo
18981       enddo
18982 ! Calculating numerical gradients for dU/ddx
18983       do i=0,nres-1
18984        duxcartan(j,i)=0.0d0
18985        do j=1,3
18986           cdummy(j,i)=dc(j,i+nres)
18987           dc(j,i+nres)=dc(j,i+nres)+delta
18988           call chainbuild_cart
18989         uzap2=0.0d0
18990           do ii=1,nfrag
18991            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18992             idummy,idummy)
18993              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18994             qinfrag(ii,iset))
18995           enddo
18996           do ii=1,npair
18997              kstart=ifrag(1,ipair(1,ii,iset),iset)
18998              kend=ifrag(2,ipair(1,ii,iset),iset)
18999              lstart=ifrag(1,ipair(2,ii,iset),iset)
19000              lend=ifrag(2,ipair(2,ii,iset),iset)
19001              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
19002              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
19003             qinpair(ii,iset))
19004           enddo
19005           dc(j,i+nres)=cdummy(j,i)
19006           call chainbuild_cart
19007           uzap1=0.0d0
19008            do ii=1,nfrag
19009              qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
19010             ifrag(2,ii,iset),.true.,idummy,idummy)
19011              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
19012             qinfrag(ii,iset))
19013           enddo
19014           do ii=1,npair
19015              kstart=ifrag(1,ipair(1,ii,iset),iset)
19016              kend=ifrag(2,ipair(1,ii,iset),iset)
19017              lstart=ifrag(1,ipair(2,ii,iset),iset)
19018              lend=ifrag(2,ipair(2,ii,iset),iset)
19019              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
19020              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
19021             qinpair(ii,iset))
19022           enddo
19023           duxcartan(j,i)=(uzap2-uzap1)/(delta)
19024        enddo
19025       enddo
19026       write(iout,*) "Numerical dUconst/ddc backbone "
19027       do ii=0,nres
19028       write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
19029       enddo
19030 !      write(iout,*) "Numerical dUconst/ddx side-chain "
19031 !      do ii=1,nres
19032 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
19033 !      enddo
19034       return
19035       end subroutine dEconstrQ_num
19036 !-----------------------------------------------------------------------------
19037 ! ssMD.F
19038 !-----------------------------------------------------------------------------
19039       subroutine check_energies
19040
19041 !      use random, only: ran_number
19042
19043 !      implicit none
19044 !     Includes
19045 !      include 'DIMENSIONS'
19046 !      include 'COMMON.CHAIN'
19047 !      include 'COMMON.VAR'
19048 !      include 'COMMON.IOUNITS'
19049 !      include 'COMMON.SBRIDGE'
19050 !      include 'COMMON.LOCAL'
19051 !      include 'COMMON.GEO'
19052
19053 !     External functions
19054 !EL      double precision ran_number
19055 !EL      external ran_number
19056
19057 !     Local variables
19058       integer :: i,j,k,l,lmax,p,pmax
19059       real(kind=8) :: rmin,rmax
19060       real(kind=8) :: eij
19061
19062       real(kind=8) :: d
19063       real(kind=8) :: wi,rij,tj,pj
19064 !      return
19065
19066       i=5
19067       j=14
19068
19069       d=dsc(1)
19070       rmin=2.0D0
19071       rmax=12.0D0
19072
19073       lmax=10000
19074       pmax=1
19075
19076       do k=1,3
19077       c(k,i)=0.0D0
19078       c(k,j)=0.0D0
19079       c(k,nres+i)=0.0D0
19080       c(k,nres+j)=0.0D0
19081       enddo
19082
19083       do l=1,lmax
19084
19085 !t        wi=ran_number(0.0D0,pi)
19086 !        wi=ran_number(0.0D0,pi/6.0D0)
19087 !        wi=0.0D0
19088 !t        tj=ran_number(0.0D0,pi)
19089 !t        pj=ran_number(0.0D0,pi)
19090 !        pj=ran_number(0.0D0,pi/6.0D0)
19091 !        pj=0.0D0
19092
19093       do p=1,pmax
19094 !t           rij=ran_number(rmin,rmax)
19095
19096          c(1,j)=d*sin(pj)*cos(tj)
19097          c(2,j)=d*sin(pj)*sin(tj)
19098          c(3,j)=d*cos(pj)
19099
19100          c(3,nres+i)=-rij
19101
19102          c(1,i)=d*sin(wi)
19103          c(3,i)=-rij-d*cos(wi)
19104
19105          do k=1,3
19106             dc(k,nres+i)=c(k,nres+i)-c(k,i)
19107             dc_norm(k,nres+i)=dc(k,nres+i)/d
19108             dc(k,nres+j)=c(k,nres+j)-c(k,j)
19109             dc_norm(k,nres+j)=dc(k,nres+j)/d
19110          enddo
19111
19112          call dyn_ssbond_ene(i,j,eij)
19113       enddo
19114       enddo
19115       call exit(1)
19116       return
19117       end subroutine check_energies
19118 !-----------------------------------------------------------------------------
19119       subroutine dyn_ssbond_ene(resi,resj,eij)
19120 !      implicit none
19121 !      Includes
19122       use calc_data
19123       use comm_sschecks
19124 !      include 'DIMENSIONS'
19125 !      include 'COMMON.SBRIDGE'
19126 !      include 'COMMON.CHAIN'
19127 !      include 'COMMON.DERIV'
19128 !      include 'COMMON.LOCAL'
19129 !      include 'COMMON.INTERACT'
19130 !      include 'COMMON.VAR'
19131 !      include 'COMMON.IOUNITS'
19132 !      include 'COMMON.CALC'
19133 #ifndef CLUST
19134 #ifndef WHAM
19135        use MD_data
19136 !      include 'COMMON.MD'
19137 !      use MD, only: totT,t_bath
19138 #endif
19139 #endif
19140 !     External functions
19141 !EL      double precision h_base
19142 !EL      external h_base
19143
19144 !     Input arguments
19145       integer :: resi,resj
19146
19147 !     Output arguments
19148       real(kind=8) :: eij
19149
19150 !     Local variables
19151       logical :: havebond
19152       integer itypi,itypj
19153       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
19154       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
19155       real(kind=8),dimension(3) :: dcosom1,dcosom2
19156       real(kind=8) :: ed
19157       real(kind=8) :: pom1,pom2
19158       real(kind=8) :: ljA,ljB,ljXs
19159       real(kind=8),dimension(1:3) :: d_ljB
19160       real(kind=8) :: ssA,ssB,ssC,ssXs
19161       real(kind=8) :: ssxm,ljxm,ssm,ljm
19162       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
19163       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
19164       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
19165 !-------FIRST METHOD
19166       real(kind=8) :: xm
19167       real(kind=8),dimension(1:3) :: d_xm
19168 !-------END FIRST METHOD
19169 !-------SECOND METHOD
19170 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
19171 !-------END SECOND METHOD
19172
19173 !-------TESTING CODE
19174 !el      logical :: checkstop,transgrad
19175 !el      common /sschecks/ checkstop,transgrad
19176
19177       integer :: icheck,nicheck,jcheck,njcheck
19178       real(kind=8),dimension(-1:1) :: echeck
19179       real(kind=8) :: deps,ssx0,ljx0
19180 !-------END TESTING CODE
19181
19182       eij=0.0d0
19183       i=resi
19184       j=resj
19185
19186 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
19187 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
19188
19189       itypi=itype(i,1)
19190       dxi=dc_norm(1,nres+i)
19191       dyi=dc_norm(2,nres+i)
19192       dzi=dc_norm(3,nres+i)
19193       dsci_inv=vbld_inv(i+nres)
19194
19195       itypj=itype(j,1)
19196       xj=c(1,nres+j)-c(1,nres+i)
19197       yj=c(2,nres+j)-c(2,nres+i)
19198       zj=c(3,nres+j)-c(3,nres+i)
19199       dxj=dc_norm(1,nres+j)
19200       dyj=dc_norm(2,nres+j)
19201       dzj=dc_norm(3,nres+j)
19202       dscj_inv=vbld_inv(j+nres)
19203
19204       chi1=chi(itypi,itypj)
19205       chi2=chi(itypj,itypi)
19206       chi12=chi1*chi2
19207       chip1=chip(itypi)
19208       chip2=chip(itypj)
19209       chip12=chip1*chip2
19210       alf1=alp(itypi)
19211       alf2=alp(itypj)
19212       alf12=0.5D0*(alf1+alf2)
19213
19214       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
19215       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
19216 !     The following are set in sc_angular
19217 !      erij(1)=xj*rij
19218 !      erij(2)=yj*rij
19219 !      erij(3)=zj*rij
19220 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
19221 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
19222 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
19223       call sc_angular
19224       rij=1.0D0/rij  ! Reset this so it makes sense
19225
19226       sig0ij=sigma(itypi,itypj)
19227       sig=sig0ij*dsqrt(1.0D0/sigsq)
19228
19229       ljXs=sig-sig0ij
19230       ljA=eps1*eps2rt**2*eps3rt**2
19231       ljB=ljA*bb_aq(itypi,itypj)
19232       ljA=ljA*aa_aq(itypi,itypj)
19233       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
19234
19235       ssXs=d0cm
19236       deltat1=1.0d0-om1
19237       deltat2=1.0d0+om2
19238       deltat12=om2-om1+2.0d0
19239       cosphi=om12-om1*om2
19240       ssA=akcm
19241       ssB=akct*deltat12
19242       ssC=ss_depth &
19243          +akth*(deltat1*deltat1+deltat2*deltat2) &
19244          +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
19245       ssxm=ssXs-0.5D0*ssB/ssA
19246
19247 !-------TESTING CODE
19248 !$$$c     Some extra output
19249 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
19250 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
19251 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
19252 !$$$      if (ssx0.gt.0.0d0) then
19253 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
19254 !$$$      else
19255 !$$$        ssx0=ssxm
19256 !$$$      endif
19257 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
19258 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
19259 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
19260 !$$$      return
19261 !-------END TESTING CODE
19262
19263 !-------TESTING CODE
19264 !     Stop and plot energy and derivative as a function of distance
19265       if (checkstop) then
19266       ssm=ssC-0.25D0*ssB*ssB/ssA
19267       ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
19268       if (ssm.lt.ljm .and. &
19269            dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
19270         nicheck=1000
19271         njcheck=1
19272         deps=0.5d-7
19273       else
19274         checkstop=.false.
19275       endif
19276       endif
19277       if (.not.checkstop) then
19278       nicheck=0
19279       njcheck=-1
19280       endif
19281
19282       do icheck=0,nicheck
19283       do jcheck=-1,njcheck
19284       if (checkstop) rij=(ssxm-1.0d0)+ &
19285            ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
19286 !-------END TESTING CODE
19287
19288       if (rij.gt.ljxm) then
19289       havebond=.false.
19290       ljd=rij-ljXs
19291       fac=(1.0D0/ljd)**expon
19292       e1=fac*fac*aa_aq(itypi,itypj)
19293       e2=fac*bb_aq(itypi,itypj)
19294       eij=eps1*eps2rt*eps3rt*(e1+e2)
19295       eps2der=eij*eps3rt
19296       eps3der=eij*eps2rt
19297       eij=eij*eps2rt*eps3rt
19298
19299       sigder=-sig/sigsq
19300       e1=e1*eps1*eps2rt**2*eps3rt**2
19301       ed=-expon*(e1+eij)/ljd
19302       sigder=ed*sigder
19303       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
19304       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
19305       eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
19306            -2.0D0*alf12*eps3der+sigder*sigsq_om12
19307       else if (rij.lt.ssxm) then
19308       havebond=.true.
19309       ssd=rij-ssXs
19310       eij=ssA*ssd*ssd+ssB*ssd+ssC
19311
19312       ed=2*akcm*ssd+akct*deltat12
19313       pom1=akct*ssd
19314       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
19315       eom1=-2*akth*deltat1-pom1-om2*pom2
19316       eom2= 2*akth*deltat2+pom1-om1*pom2
19317       eom12=pom2
19318       else
19319       omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
19320
19321       d_ssxm(1)=0.5D0*akct/ssA
19322       d_ssxm(2)=-d_ssxm(1)
19323       d_ssxm(3)=0.0D0
19324
19325       d_ljxm(1)=sig0ij/sqrt(sigsq**3)
19326       d_ljxm(2)=d_ljxm(1)*sigsq_om2
19327       d_ljxm(3)=d_ljxm(1)*sigsq_om12
19328       d_ljxm(1)=d_ljxm(1)*sigsq_om1
19329
19330 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
19331       xm=0.5d0*(ssxm+ljxm)
19332       do k=1,3
19333         d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
19334       enddo
19335       if (rij.lt.xm) then
19336         havebond=.true.
19337         ssm=ssC-0.25D0*ssB*ssB/ssA
19338         d_ssm(1)=0.5D0*akct*ssB/ssA
19339         d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
19340         d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
19341         d_ssm(3)=omega
19342         f1=(rij-xm)/(ssxm-xm)
19343         f2=(rij-ssxm)/(xm-ssxm)
19344         h1=h_base(f1,hd1)
19345         h2=h_base(f2,hd2)
19346         eij=ssm*h1+Ht*h2
19347         delta_inv=1.0d0/(xm-ssxm)
19348         deltasq_inv=delta_inv*delta_inv
19349         fac=ssm*hd1-Ht*hd2
19350         fac1=deltasq_inv*fac*(xm-rij)
19351         fac2=deltasq_inv*fac*(rij-ssxm)
19352         ed=delta_inv*(Ht*hd2-ssm*hd1)
19353         eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
19354         eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
19355         eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
19356       else
19357         havebond=.false.
19358         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
19359         d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
19360         d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
19361         d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
19362              alf12/eps3rt)
19363         d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
19364         f1=(rij-ljxm)/(xm-ljxm)
19365         f2=(rij-xm)/(ljxm-xm)
19366         h1=h_base(f1,hd1)
19367         h2=h_base(f2,hd2)
19368         eij=Ht*h1+ljm*h2
19369         delta_inv=1.0d0/(ljxm-xm)
19370         deltasq_inv=delta_inv*delta_inv
19371         fac=Ht*hd1-ljm*hd2
19372         fac1=deltasq_inv*fac*(ljxm-rij)
19373         fac2=deltasq_inv*fac*(rij-xm)
19374         ed=delta_inv*(ljm*hd2-Ht*hd1)
19375         eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
19376         eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
19377         eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
19378       endif
19379 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
19380
19381 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
19382 !$$$        ssd=rij-ssXs
19383 !$$$        ljd=rij-ljXs
19384 !$$$        fac1=rij-ljxm
19385 !$$$        fac2=rij-ssxm
19386 !$$$
19387 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
19388 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
19389 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
19390 !$$$
19391 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
19392 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
19393 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
19394 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
19395 !$$$        d_ssm(3)=omega
19396 !$$$
19397 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
19398 !$$$        do k=1,3
19399 !$$$          d_ljm(k)=ljm*d_ljB(k)
19400 !$$$        enddo
19401 !$$$        ljm=ljm*ljB
19402 !$$$
19403 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
19404 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
19405 !$$$        d_ss(2)=akct*ssd
19406 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
19407 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
19408 !$$$        d_ss(3)=omega
19409 !$$$
19410 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
19411 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
19412 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
19413 !$$$        do k=1,3
19414 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
19415 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
19416 !$$$        enddo
19417 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
19418 !$$$
19419 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
19420 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
19421 !$$$        h1=h_base(f1,hd1)
19422 !$$$        h2=h_base(f2,hd2)
19423 !$$$        eij=ss*h1+ljf*h2
19424 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
19425 !$$$        deltasq_inv=delta_inv*delta_inv
19426 !$$$        fac=ljf*hd2-ss*hd1
19427 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
19428 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
19429 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
19430 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
19431 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
19432 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
19433 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
19434 !$$$
19435 !$$$        havebond=.false.
19436 !$$$        if (ed.gt.0.0d0) havebond=.true.
19437 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
19438
19439       endif
19440
19441       if (havebond) then
19442 !#ifndef CLUST
19443 !#ifndef WHAM
19444 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
19445 !          write(iout,'(a15,f12.2,f8.1,2i5)')
19446 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
19447 !        endif
19448 !#endif
19449 !#endif
19450       dyn_ssbond_ij(i,j)=eij
19451       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
19452       dyn_ssbond_ij(i,j)=1.0d300
19453 !#ifndef CLUST
19454 !#ifndef WHAM
19455 !        write(iout,'(a15,f12.2,f8.1,2i5)')
19456 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
19457 !#endif
19458 !#endif
19459       endif
19460
19461 !-------TESTING CODE
19462 !el      if (checkstop) then
19463       if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
19464            "CHECKSTOP",rij,eij,ed
19465       echeck(jcheck)=eij
19466 !el      endif
19467       enddo
19468       if (checkstop) then
19469       write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
19470       endif
19471       enddo
19472       if (checkstop) then
19473       transgrad=.true.
19474       checkstop=.false.
19475       endif
19476 !-------END TESTING CODE
19477
19478       do k=1,3
19479       dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
19480       dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
19481       enddo
19482       do k=1,3
19483       gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
19484       enddo
19485       do k=1,3
19486       gvdwx(k,i)=gvdwx(k,i)-gg(k) &
19487            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
19488            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
19489       gvdwx(k,j)=gvdwx(k,j)+gg(k) &
19490            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
19491            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
19492       enddo
19493 !grad      do k=i,j-1
19494 !grad        do l=1,3
19495 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
19496 !grad        enddo
19497 !grad      enddo
19498
19499       do l=1,3
19500       gvdwc(l,i)=gvdwc(l,i)-gg(l)
19501       gvdwc(l,j)=gvdwc(l,j)+gg(l)
19502       enddo
19503
19504       return
19505       end subroutine dyn_ssbond_ene
19506 !--------------------------------------------------------------------------
19507        subroutine triple_ssbond_ene(resi,resj,resk,eij)
19508 !      implicit none
19509 !      Includes
19510       use calc_data
19511       use comm_sschecks
19512 !      include 'DIMENSIONS'
19513 !      include 'COMMON.SBRIDGE'
19514 !      include 'COMMON.CHAIN'
19515 !      include 'COMMON.DERIV'
19516 !      include 'COMMON.LOCAL'
19517 !      include 'COMMON.INTERACT'
19518 !      include 'COMMON.VAR'
19519 !      include 'COMMON.IOUNITS'
19520 !      include 'COMMON.CALC'
19521 #ifndef CLUST
19522 #ifndef WHAM
19523        use MD_data
19524 !      include 'COMMON.MD'
19525 !      use MD, only: totT,t_bath
19526 #endif
19527 #endif
19528       double precision h_base
19529       external h_base
19530
19531 !c     Input arguments
19532       integer resi,resj,resk,m,itypi,itypj,itypk
19533
19534 !c     Output arguments
19535       double precision eij,eij1,eij2,eij3
19536
19537 !c     Local variables
19538       logical havebond
19539 !c      integer itypi,itypj,k,l
19540       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
19541       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
19542       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
19543       double precision sig0ij,ljd,sig,fac,e1,e2
19544       double precision dcosom1(3),dcosom2(3),ed
19545       double precision pom1,pom2
19546       double precision ljA,ljB,ljXs
19547       double precision d_ljB(1:3)
19548       double precision ssA,ssB,ssC,ssXs
19549       double precision ssxm,ljxm,ssm,ljm
19550       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
19551       eij=0.0
19552       if (dtriss.eq.0) return
19553       i=resi
19554       j=resj
19555       k=resk
19556 !C      write(iout,*) resi,resj,resk
19557       itypi=itype(i,1)
19558       dxi=dc_norm(1,nres+i)
19559       dyi=dc_norm(2,nres+i)
19560       dzi=dc_norm(3,nres+i)
19561       dsci_inv=vbld_inv(i+nres)
19562       xi=c(1,nres+i)
19563       yi=c(2,nres+i)
19564       zi=c(3,nres+i)
19565       call to_box(xi,yi,zi)
19566       itypj=itype(j,1)
19567       xj=c(1,nres+j)
19568       yj=c(2,nres+j)
19569       zj=c(3,nres+j)
19570       call to_box(xj,yj,zj)
19571       dxj=dc_norm(1,nres+j)
19572       dyj=dc_norm(2,nres+j)
19573       dzj=dc_norm(3,nres+j)
19574       dscj_inv=vbld_inv(j+nres)
19575       itypk=itype(k,1)
19576       xk=c(1,nres+k)
19577       yk=c(2,nres+k)
19578       zk=c(3,nres+k)
19579        call to_box(xk,yk,zk)
19580       dxk=dc_norm(1,nres+k)
19581       dyk=dc_norm(2,nres+k)
19582       dzk=dc_norm(3,nres+k)
19583       dscj_inv=vbld_inv(k+nres)
19584       xij=xj-xi
19585       xik=xk-xi
19586       xjk=xk-xj
19587       yij=yj-yi
19588       yik=yk-yi
19589       yjk=yk-yj
19590       zij=zj-zi
19591       zik=zk-zi
19592       zjk=zk-zj
19593       rrij=(xij*xij+yij*yij+zij*zij)
19594       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
19595       rrik=(xik*xik+yik*yik+zik*zik)
19596       rik=dsqrt(rrik)
19597       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
19598       rjk=dsqrt(rrjk)
19599 !C there are three combination of distances for each trisulfide bonds
19600 !C The first case the ith atom is the center
19601 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
19602 !C distance y is second distance the a,b,c,d are parameters derived for
19603 !C this problem d parameter was set as a penalty currenlty set to 1.
19604       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
19605       eij1=0.0d0
19606       else
19607       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
19608       endif
19609 !C second case jth atom is center
19610       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
19611       eij2=0.0d0
19612       else
19613       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
19614       endif
19615 !C the third case kth atom is the center
19616       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
19617       eij3=0.0d0
19618       else
19619       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
19620       endif
19621 !C      eij2=0.0
19622 !C      eij3=0.0
19623 !C      eij1=0.0
19624       eij=eij1+eij2+eij3
19625 !C      write(iout,*)i,j,k,eij
19626 !C The energy penalty calculated now time for the gradient part
19627 !C derivative over rij
19628       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19629       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
19630           gg(1)=xij*fac/rij
19631           gg(2)=yij*fac/rij
19632           gg(3)=zij*fac/rij
19633       do m=1,3
19634       gvdwx(m,i)=gvdwx(m,i)-gg(m)
19635       gvdwx(m,j)=gvdwx(m,j)+gg(m)
19636       enddo
19637
19638       do l=1,3
19639       gvdwc(l,i)=gvdwc(l,i)-gg(l)
19640       gvdwc(l,j)=gvdwc(l,j)+gg(l)
19641       enddo
19642 !C now derivative over rik
19643       fac=-eij1**2/dtriss* &
19644       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19645       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19646           gg(1)=xik*fac/rik
19647           gg(2)=yik*fac/rik
19648           gg(3)=zik*fac/rik
19649       do m=1,3
19650       gvdwx(m,i)=gvdwx(m,i)-gg(m)
19651       gvdwx(m,k)=gvdwx(m,k)+gg(m)
19652       enddo
19653       do l=1,3
19654       gvdwc(l,i)=gvdwc(l,i)-gg(l)
19655       gvdwc(l,k)=gvdwc(l,k)+gg(l)
19656       enddo
19657 !C now derivative over rjk
19658       fac=-eij2**2/dtriss* &
19659       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
19660       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19661           gg(1)=xjk*fac/rjk
19662           gg(2)=yjk*fac/rjk
19663           gg(3)=zjk*fac/rjk
19664       do m=1,3
19665       gvdwx(m,j)=gvdwx(m,j)-gg(m)
19666       gvdwx(m,k)=gvdwx(m,k)+gg(m)
19667       enddo
19668       do l=1,3
19669       gvdwc(l,j)=gvdwc(l,j)-gg(l)
19670       gvdwc(l,k)=gvdwc(l,k)+gg(l)
19671       enddo
19672       return
19673       end subroutine triple_ssbond_ene
19674
19675
19676
19677 !-----------------------------------------------------------------------------
19678       real(kind=8) function h_base(x,deriv)
19679 !     A smooth function going 0->1 in range [0,1]
19680 !     It should NOT be called outside range [0,1], it will not work there.
19681       implicit none
19682
19683 !     Input arguments
19684       real(kind=8) :: x
19685
19686 !     Output arguments
19687       real(kind=8) :: deriv
19688
19689 !     Local variables
19690       real(kind=8) :: xsq
19691
19692
19693 !     Two parabolas put together.  First derivative zero at extrema
19694 !$$$      if (x.lt.0.5D0) then
19695 !$$$        h_base=2.0D0*x*x
19696 !$$$        deriv=4.0D0*x
19697 !$$$      else
19698 !$$$        deriv=1.0D0-x
19699 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
19700 !$$$        deriv=4.0D0*deriv
19701 !$$$      endif
19702
19703 !     Third degree polynomial.  First derivative zero at extrema
19704       h_base=x*x*(3.0d0-2.0d0*x)
19705       deriv=6.0d0*x*(1.0d0-x)
19706
19707 !     Fifth degree polynomial.  First and second derivatives zero at extrema
19708 !$$$      xsq=x*x
19709 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
19710 !$$$      deriv=x-1.0d0
19711 !$$$      deriv=deriv*deriv
19712 !$$$      deriv=30.0d0*xsq*deriv
19713
19714       return
19715       end function h_base
19716 !-----------------------------------------------------------------------------
19717       subroutine dyn_set_nss
19718 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
19719 !      implicit none
19720       use MD_data, only: totT,t_bath
19721 !     Includes
19722 !      include 'DIMENSIONS'
19723 #ifdef MPI
19724       include "mpif.h"
19725 #endif
19726 !      include 'COMMON.SBRIDGE'
19727 !      include 'COMMON.CHAIN'
19728 !      include 'COMMON.IOUNITS'
19729 !      include 'COMMON.SETUP'
19730 !      include 'COMMON.MD'
19731 !     Local variables
19732       real(kind=8) :: emin
19733       integer :: i,j,imin,ierr
19734       integer :: diff,allnss,newnss
19735       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19736             newihpb,newjhpb
19737       logical :: found
19738       integer,dimension(0:nfgtasks) :: i_newnss
19739       integer,dimension(0:nfgtasks) :: displ
19740       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19741       integer :: g_newnss
19742
19743       allnss=0
19744       do i=1,nres-1
19745       do j=i+1,nres
19746         if (dyn_ssbond_ij(i,j).lt.1.0d300) then
19747           allnss=allnss+1
19748           allflag(allnss)=0
19749           allihpb(allnss)=i
19750           alljhpb(allnss)=j
19751         endif
19752       enddo
19753       enddo
19754
19755 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19756
19757  1    emin=1.0d300
19758       do i=1,allnss
19759       if (allflag(i).eq.0 .and. &
19760            dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
19761         emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
19762         imin=i
19763       endif
19764       enddo
19765       if (emin.lt.1.0d300) then
19766       allflag(imin)=1
19767       do i=1,allnss
19768         if (allflag(i).eq.0 .and. &
19769              (allihpb(i).eq.allihpb(imin) .or. &
19770              alljhpb(i).eq.allihpb(imin) .or. &
19771              allihpb(i).eq.alljhpb(imin) .or. &
19772              alljhpb(i).eq.alljhpb(imin))) then
19773           allflag(i)=-1
19774         endif
19775       enddo
19776       goto 1
19777       endif
19778
19779 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19780
19781       newnss=0
19782       do i=1,allnss
19783       if (allflag(i).eq.1) then
19784         newnss=newnss+1
19785         newihpb(newnss)=allihpb(i)
19786         newjhpb(newnss)=alljhpb(i)
19787       endif
19788       enddo
19789
19790 #ifdef MPI
19791       if (nfgtasks.gt.1)then
19792
19793       call MPI_Reduce(newnss,g_newnss,1,&
19794         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
19795       call MPI_Gather(newnss,1,MPI_INTEGER,&
19796                   i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
19797       displ(0)=0
19798       do i=1,nfgtasks-1,1
19799         displ(i)=i_newnss(i-1)+displ(i-1)
19800       enddo
19801       call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
19802                    g_newihpb,i_newnss,displ,MPI_INTEGER,&
19803                    king,FG_COMM,IERR)
19804       call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
19805                    g_newjhpb,i_newnss,displ,MPI_INTEGER,&
19806                    king,FG_COMM,IERR)
19807       if(fg_rank.eq.0) then
19808 !         print *,'g_newnss',g_newnss
19809 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
19810 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
19811        newnss=g_newnss
19812        do i=1,newnss
19813         newihpb(i)=g_newihpb(i)
19814         newjhpb(i)=g_newjhpb(i)
19815        enddo
19816       endif
19817       endif
19818 #endif
19819
19820       diff=newnss-nss
19821
19822 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
19823 !       print *,newnss,nss,maxdim
19824       do i=1,nss
19825       found=.false.
19826 !        print *,newnss
19827       do j=1,newnss
19828 !!          print *,j
19829         if (idssb(i).eq.newihpb(j) .and. &
19830              jdssb(i).eq.newjhpb(j)) found=.true.
19831       enddo
19832 #if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
19833 !        write(iout,*) "found",found,i,j
19834       if (.not.found.and.fg_rank.eq.0) &
19835           write(iout,'(a15,f12.2,f8.1,2i5)') &
19836            "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
19837 #endif
19838       enddo
19839
19840       do i=1,newnss
19841       found=.false.
19842       do j=1,nss
19843 !          print *,i,j
19844         if (newihpb(i).eq.idssb(j) .and. &
19845              newjhpb(i).eq.jdssb(j)) found=.true.
19846       enddo
19847 #if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
19848 !        write(iout,*) "found",found,i,j
19849       if (.not.found.and.fg_rank.eq.0) &
19850           write(iout,'(a15,f12.2,f8.1,2i5)') &
19851            "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
19852 #endif
19853       enddo
19854 !#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
19855       nss=newnss
19856       do i=1,nss
19857       idssb(i)=newihpb(i)
19858       jdssb(i)=newjhpb(i)
19859       enddo
19860 !#else
19861 !      nss=0
19862 !#endif
19863
19864       return
19865       end subroutine dyn_set_nss
19866 ! Lipid transfer energy function
19867       subroutine Eliptransfer(eliptran)
19868 !C this is done by Adasko
19869 !C      print *,"wchodze"
19870 !C structure of box:
19871 !C      water
19872 !C--bordliptop-- buffore starts
19873 !C--bufliptop--- here true lipid starts
19874 !C      lipid
19875 !C--buflipbot--- lipid ends buffore starts
19876 !C--bordlipbot--buffore ends
19877       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
19878       integer :: i
19879       eliptran=0.0
19880 !      print *, "I am in eliptran"
19881       do i=ilip_start,ilip_end
19882 !C       do i=1,1
19883       if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
19884        cycle
19885
19886       positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
19887       if (positi.le.0.0) positi=positi+boxzsize
19888 !C        print *,i
19889 !C first for peptide groups
19890 !c for each residue check if it is in lipid or lipid water border area
19891        if ((positi.gt.bordlipbot)  &
19892       .and.(positi.lt.bordliptop)) then
19893 !C the energy transfer exist
19894       if (positi.lt.buflipbot) then
19895 !C what fraction I am in
19896        fracinbuf=1.0d0-      &
19897            ((positi-bordlipbot)/lipbufthick)
19898 !C lipbufthick is thickenes of lipid buffore
19899        sslip=sscalelip(fracinbuf)
19900        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19901        eliptran=eliptran+sslip*pepliptran
19902        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19903        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19904 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19905
19906 !C        print *,"doing sccale for lower part"
19907 !C         print *,i,sslip,fracinbuf,ssgradlip
19908       elseif (positi.gt.bufliptop) then
19909        fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
19910        sslip=sscalelip(fracinbuf)
19911        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19912        eliptran=eliptran+sslip*pepliptran
19913        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19914        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19915 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19916 !C          print *, "doing sscalefor top part"
19917 !C         print *,i,sslip,fracinbuf,ssgradlip
19918       else
19919        eliptran=eliptran+pepliptran
19920 !C         print *,"I am in true lipid"
19921       endif
19922 !C       else
19923 !C       eliptran=elpitran+0.0 ! I am in water
19924        endif
19925        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
19926        enddo
19927 ! here starts the side chain transfer
19928        do i=ilip_start,ilip_end
19929       if (itype(i,1).eq.ntyp1) cycle
19930       positi=(mod(c(3,i+nres),boxzsize))
19931       if (positi.le.0) positi=positi+boxzsize
19932 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19933 !c for each residue check if it is in lipid or lipid water border area
19934 !C       respos=mod(c(3,i+nres),boxzsize)
19935 !C       print *,positi,bordlipbot,buflipbot
19936        if ((positi.gt.bordlipbot) &
19937        .and.(positi.lt.bordliptop)) then
19938 !C the energy transfer exist
19939       if (positi.lt.buflipbot) then
19940        fracinbuf=1.0d0-   &
19941          ((positi-bordlipbot)/lipbufthick)
19942 !C lipbufthick is thickenes of lipid buffore
19943        sslip=sscalelip(fracinbuf)
19944        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19945        eliptran=eliptran+sslip*liptranene(itype(i,1))
19946        gliptranx(3,i)=gliptranx(3,i) &
19947       +ssgradlip*liptranene(itype(i,1))
19948        gliptranc(3,i-1)= gliptranc(3,i-1) &
19949       +ssgradlip*liptranene(itype(i,1))
19950 !C         print *,"doing sccale for lower part"
19951       elseif (positi.gt.bufliptop) then
19952        fracinbuf=1.0d0-  &
19953       ((bordliptop-positi)/lipbufthick)
19954        sslip=sscalelip(fracinbuf)
19955        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19956        eliptran=eliptran+sslip*liptranene(itype(i,1))
19957        gliptranx(3,i)=gliptranx(3,i)  &
19958        +ssgradlip*liptranene(itype(i,1))
19959        gliptranc(3,i-1)= gliptranc(3,i-1) &
19960       +ssgradlip*liptranene(itype(i,1))
19961 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19962       else
19963        eliptran=eliptran+liptranene(itype(i,1))
19964 !C         print *,"I am in true lipid"
19965       endif
19966       endif ! if in lipid or buffor
19967 !C       else
19968 !C       eliptran=elpitran+0.0 ! I am in water
19969       if (energy_dec) write(iout,*) i,"eliptran=",eliptran
19970        enddo
19971        return
19972        end  subroutine Eliptransfer
19973 !----------------------------------NANO FUNCTIONS
19974 !C-----------------------------------------------------------------------
19975 !C-----------------------------------------------------------
19976 !C This subroutine is to mimic the histone like structure but as well can be
19977 !C utilizet to nanostructures (infinit) small modification has to be used to
19978 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19979 !C gradient has to be modified at the ends
19980 !C The energy function is Kihara potential
19981 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19982 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19983 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19984 !C simple Kihara potential
19985       subroutine calctube(Etube)
19986       real(kind=8),dimension(3) :: vectube
19987       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19988        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
19989        sc_aa_tube,sc_bb_tube
19990       integer :: i,j,iti
19991       Etube=0.0d0
19992       do i=itube_start,itube_end
19993       enetube(i)=0.0d0
19994       enetube(i+nres)=0.0d0
19995       enddo
19996 !C first we calculate the distance from tube center
19997 !C for UNRES
19998        do i=itube_start,itube_end
19999 !C lets ommit dummy atoms for now
20000        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
20001 !C now calculate distance from center of tube and direction vectors
20002       xmin=boxxsize
20003       ymin=boxysize
20004 ! Find minimum distance in periodic box
20005       do j=-1,1
20006        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20007        vectube(1)=vectube(1)+boxxsize*j
20008        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20009        vectube(2)=vectube(2)+boxysize*j
20010        xminact=abs(vectube(1)-tubecenter(1))
20011        yminact=abs(vectube(2)-tubecenter(2))
20012          if (xmin.gt.xminact) then
20013           xmin=xminact
20014           xtemp=vectube(1)
20015          endif
20016          if (ymin.gt.yminact) then
20017            ymin=yminact
20018            ytemp=vectube(2)
20019           endif
20020        enddo
20021       vectube(1)=xtemp
20022       vectube(2)=ytemp
20023       vectube(1)=vectube(1)-tubecenter(1)
20024       vectube(2)=vectube(2)-tubecenter(2)
20025
20026 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20027 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20028
20029 !C as the tube is infinity we do not calculate the Z-vector use of Z
20030 !C as chosen axis
20031       vectube(3)=0.0d0
20032 !C now calculte the distance
20033        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20034 !C now normalize vector
20035       vectube(1)=vectube(1)/tub_r
20036       vectube(2)=vectube(2)/tub_r
20037 !C calculte rdiffrence between r and r0
20038       rdiff=tub_r-tubeR0
20039 !C and its 6 power
20040       rdiff6=rdiff**6.0d0
20041 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20042        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
20043 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
20044 !C       print *,rdiff,rdiff6,pep_aa_tube
20045 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20046 !C now we calculate gradient
20047        fac=(-12.0d0*pep_aa_tube/rdiff6- &
20048           6.0d0*pep_bb_tube)/rdiff6/rdiff
20049 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
20050 !C     &rdiff,fac
20051 !C now direction of gg_tube vector
20052       do j=1,3
20053       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
20054       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
20055       enddo
20056       enddo
20057 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
20058 !C        print *,gg_tube(1,0),"TU"
20059
20060
20061        do i=itube_start,itube_end
20062 !C Lets not jump over memory as we use many times iti
20063        iti=itype(i,1)
20064 !C lets ommit dummy atoms for now
20065        if ((iti.eq.ntyp1)  &
20066 !C in UNRES uncomment the line below as GLY has no side-chain...
20067 !C      .or.(iti.eq.10)
20068       ) cycle
20069       xmin=boxxsize
20070       ymin=boxysize
20071       do j=-1,1
20072        vectube(1)=mod((c(1,i+nres)),boxxsize)
20073        vectube(1)=vectube(1)+boxxsize*j
20074        vectube(2)=mod((c(2,i+nres)),boxysize)
20075        vectube(2)=vectube(2)+boxysize*j
20076
20077        xminact=abs(vectube(1)-tubecenter(1))
20078        yminact=abs(vectube(2)-tubecenter(2))
20079          if (xmin.gt.xminact) then
20080           xmin=xminact
20081           xtemp=vectube(1)
20082          endif
20083          if (ymin.gt.yminact) then
20084            ymin=yminact
20085            ytemp=vectube(2)
20086           endif
20087        enddo
20088       vectube(1)=xtemp
20089       vectube(2)=ytemp
20090 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
20091 !C     &     tubecenter(2)
20092       vectube(1)=vectube(1)-tubecenter(1)
20093       vectube(2)=vectube(2)-tubecenter(2)
20094
20095 !C as the tube is infinity we do not calculate the Z-vector use of Z
20096 !C as chosen axis
20097       vectube(3)=0.0d0
20098 !C now calculte the distance
20099        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20100 !C now normalize vector
20101       vectube(1)=vectube(1)/tub_r
20102       vectube(2)=vectube(2)/tub_r
20103
20104 !C calculte rdiffrence between r and r0
20105       rdiff=tub_r-tubeR0
20106 !C and its 6 power
20107       rdiff6=rdiff**6.0d0
20108 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20109        sc_aa_tube=sc_aa_tube_par(iti)
20110        sc_bb_tube=sc_bb_tube_par(iti)
20111        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20112        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
20113            6.0d0*sc_bb_tube/rdiff6/rdiff
20114 !C now direction of gg_tube vector
20115        do j=1,3
20116         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20117         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20118        enddo
20119       enddo
20120       do i=itube_start,itube_end
20121         Etube=Etube+enetube(i)+enetube(i+nres)
20122       enddo
20123 !C        print *,"ETUBE", etube
20124       return
20125       end subroutine calctube
20126 !C TO DO 1) add to total energy
20127 !C       2) add to gradient summation
20128 !C       3) add reading parameters (AND of course oppening of PARAM file)
20129 !C       4) add reading the center of tube
20130 !C       5) add COMMONs
20131 !C       6) add to zerograd
20132 !C       7) allocate matrices
20133
20134
20135 !C-----------------------------------------------------------------------
20136 !C-----------------------------------------------------------
20137 !C This subroutine is to mimic the histone like structure but as well can be
20138 !C utilizet to nanostructures (infinit) small modification has to be used to
20139 !C make it finite (z gradient at the ends has to be changes as well as the x,y
20140 !C gradient has to be modified at the ends
20141 !C The energy function is Kihara potential
20142 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
20143 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
20144 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
20145 !C simple Kihara potential
20146       subroutine calctube2(Etube)
20147           real(kind=8),dimension(3) :: vectube
20148       real(kind=8) :: Etube,xtemp,xminact,yminact,&
20149        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
20150        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
20151       integer:: i,j,iti
20152       Etube=0.0d0
20153       do i=itube_start,itube_end
20154       enetube(i)=0.0d0
20155       enetube(i+nres)=0.0d0
20156       enddo
20157 !C first we calculate the distance from tube center
20158 !C first sugare-phosphate group for NARES this would be peptide group
20159 !C for UNRES
20160        do i=itube_start,itube_end
20161 !C lets ommit dummy atoms for now
20162
20163        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
20164 !C now calculate distance from center of tube and direction vectors
20165 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20166 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
20167 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20168 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
20169       xmin=boxxsize
20170       ymin=boxysize
20171       do j=-1,1
20172        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20173        vectube(1)=vectube(1)+boxxsize*j
20174        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20175        vectube(2)=vectube(2)+boxysize*j
20176
20177        xminact=abs(vectube(1)-tubecenter(1))
20178        yminact=abs(vectube(2)-tubecenter(2))
20179          if (xmin.gt.xminact) then
20180           xmin=xminact
20181           xtemp=vectube(1)
20182          endif
20183          if (ymin.gt.yminact) then
20184            ymin=yminact
20185            ytemp=vectube(2)
20186           endif
20187        enddo
20188       vectube(1)=xtemp
20189       vectube(2)=ytemp
20190       vectube(1)=vectube(1)-tubecenter(1)
20191       vectube(2)=vectube(2)-tubecenter(2)
20192
20193 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20194 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20195
20196 !C as the tube is infinity we do not calculate the Z-vector use of Z
20197 !C as chosen axis
20198       vectube(3)=0.0d0
20199 !C now calculte the distance
20200        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20201 !C now normalize vector
20202       vectube(1)=vectube(1)/tub_r
20203       vectube(2)=vectube(2)/tub_r
20204 !C calculte rdiffrence between r and r0
20205       rdiff=tub_r-tubeR0
20206 !C and its 6 power
20207       rdiff6=rdiff**6.0d0
20208 !C THIS FRAGMENT MAKES TUBE FINITE
20209       positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
20210       if (positi.le.0) positi=positi+boxzsize
20211 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
20212 !c for each residue check if it is in lipid or lipid water border area
20213 !C       respos=mod(c(3,i+nres),boxzsize)
20214 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
20215        if ((positi.gt.bordtubebot)  &
20216       .and.(positi.lt.bordtubetop)) then
20217 !C the energy transfer exist
20218       if (positi.lt.buftubebot) then
20219        fracinbuf=1.0d0-  &
20220          ((positi-bordtubebot)/tubebufthick)
20221 !C lipbufthick is thickenes of lipid buffore
20222        sstube=sscalelip(fracinbuf)
20223        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
20224 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
20225        enetube(i)=enetube(i)+sstube*tubetranenepep
20226 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20227 !C     &+ssgradtube*tubetranene(itype(i,1))
20228 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20229 !C     &+ssgradtube*tubetranene(itype(i,1))
20230 !C         print *,"doing sccale for lower part"
20231       elseif (positi.gt.buftubetop) then
20232        fracinbuf=1.0d0-  &
20233       ((bordtubetop-positi)/tubebufthick)
20234        sstube=sscalelip(fracinbuf)
20235        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
20236        enetube(i)=enetube(i)+sstube*tubetranenepep
20237 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20238 !C     &+ssgradtube*tubetranene(itype(i,1))
20239 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20240 !C     &+ssgradtube*tubetranene(itype(i,1))
20241 !C          print *, "doing sscalefor top part",sslip,fracinbuf
20242       else
20243        sstube=1.0d0
20244        ssgradtube=0.0d0
20245        enetube(i)=enetube(i)+sstube*tubetranenepep
20246 !C         print *,"I am in true lipid"
20247       endif
20248       else
20249 !C          sstube=0.0d0
20250 !C          ssgradtube=0.0d0
20251       cycle
20252       endif ! if in lipid or buffor
20253
20254 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20255        enetube(i)=enetube(i)+sstube* &
20256       (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
20257 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
20258 !C       print *,rdiff,rdiff6,pep_aa_tube
20259 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20260 !C now we calculate gradient
20261        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
20262            6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
20263 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
20264 !C     &rdiff,fac
20265
20266 !C now direction of gg_tube vector
20267        do j=1,3
20268       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
20269       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
20270       enddo
20271        gg_tube(3,i)=gg_tube(3,i)  &
20272        +ssgradtube*enetube(i)/sstube/2.0d0
20273        gg_tube(3,i-1)= gg_tube(3,i-1)  &
20274        +ssgradtube*enetube(i)/sstube/2.0d0
20275
20276       enddo
20277 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
20278 !C        print *,gg_tube(1,0),"TU"
20279       do i=itube_start,itube_end
20280 !C Lets not jump over memory as we use many times iti
20281        iti=itype(i,1)
20282 !C lets ommit dummy atoms for now
20283        if ((iti.eq.ntyp1) &
20284 !!C in UNRES uncomment the line below as GLY has no side-chain...
20285          .or.(iti.eq.10) &
20286         ) cycle
20287         vectube(1)=c(1,i+nres)
20288         vectube(1)=mod(vectube(1),boxxsize)
20289         if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
20290         vectube(2)=c(2,i+nres)
20291         vectube(2)=mod(vectube(2),boxysize)
20292         if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
20293
20294       vectube(1)=vectube(1)-tubecenter(1)
20295       vectube(2)=vectube(2)-tubecenter(2)
20296 !C THIS FRAGMENT MAKES TUBE FINITE
20297       positi=(mod(c(3,i+nres),boxzsize))
20298       if (positi.le.0) positi=positi+boxzsize
20299 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
20300 !c for each residue check if it is in lipid or lipid water border area
20301 !C       respos=mod(c(3,i+nres),boxzsize)
20302 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
20303
20304        if ((positi.gt.bordtubebot)  &
20305       .and.(positi.lt.bordtubetop)) then
20306 !C the energy transfer exist
20307       if (positi.lt.buftubebot) then
20308        fracinbuf=1.0d0- &
20309           ((positi-bordtubebot)/tubebufthick)
20310 !C lipbufthick is thickenes of lipid buffore
20311        sstube=sscalelip(fracinbuf)
20312        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
20313 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
20314        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
20315 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20316 !C     &+ssgradtube*tubetranene(itype(i,1))
20317 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20318 !C     &+ssgradtube*tubetranene(itype(i,1))
20319 !C         print *,"doing sccale for lower part"
20320       elseif (positi.gt.buftubetop) then
20321        fracinbuf=1.0d0- &
20322       ((bordtubetop-positi)/tubebufthick)
20323
20324        sstube=sscalelip(fracinbuf)
20325        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
20326        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
20327 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20328 !C     &+ssgradtube*tubetranene(itype(i,1))
20329 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20330 !C     &+ssgradtube*tubetranene(itype(i,1))
20331 !C          print *, "doing sscalefor top part",sslip,fracinbuf
20332       else
20333        sstube=1.0d0
20334        ssgradtube=0.0d0
20335        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
20336 !C         print *,"I am in true lipid"
20337       endif
20338       else
20339 !C          sstube=0.0d0
20340 !C          ssgradtube=0.0d0
20341       cycle
20342       endif ! if in lipid or buffor
20343 !CEND OF FINITE FRAGMENT
20344 !C as the tube is infinity we do not calculate the Z-vector use of Z
20345 !C as chosen axis
20346       vectube(3)=0.0d0
20347 !C now calculte the distance
20348        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20349 !C now normalize vector
20350       vectube(1)=vectube(1)/tub_r
20351       vectube(2)=vectube(2)/tub_r
20352 !C calculte rdiffrence between r and r0
20353       rdiff=tub_r-tubeR0
20354 !C and its 6 power
20355       rdiff6=rdiff**6.0d0
20356 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20357        sc_aa_tube=sc_aa_tube_par(iti)
20358        sc_bb_tube=sc_bb_tube_par(iti)
20359        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
20360                    *sstube+enetube(i+nres)
20361 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20362 !C now we calculate gradient
20363        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
20364           6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
20365 !C now direction of gg_tube vector
20366        do j=1,3
20367         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20368         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20369        enddo
20370        gg_tube_SC(3,i)=gg_tube_SC(3,i) &
20371        +ssgradtube*enetube(i+nres)/sstube
20372        gg_tube(3,i-1)= gg_tube(3,i-1) &
20373        +ssgradtube*enetube(i+nres)/sstube
20374
20375       enddo
20376       do i=itube_start,itube_end
20377         Etube=Etube+enetube(i)+enetube(i+nres)
20378       enddo
20379 !C        print *,"ETUBE", etube
20380       return
20381       end subroutine calctube2
20382 !=====================================================================================================================================
20383       subroutine calcnano(Etube)
20384       real(kind=8),dimension(3) :: vectube
20385
20386       real(kind=8) :: Etube,xtemp,xminact,yminact,&
20387        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
20388        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
20389        integer:: i,j,iti,r
20390
20391       Etube=0.0d0
20392 !      print *,itube_start,itube_end,"poczatek"
20393       do i=itube_start,itube_end
20394       enetube(i)=0.0d0
20395       enetube(i+nres)=0.0d0
20396       enddo
20397 !C first we calculate the distance from tube center
20398 !C first sugare-phosphate group for NARES this would be peptide group
20399 !C for UNRES
20400        do i=itube_start,itube_end
20401 !C lets ommit dummy atoms for now
20402        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
20403 !C now calculate distance from center of tube and direction vectors
20404       xmin=boxxsize
20405       ymin=boxysize
20406       zmin=boxzsize
20407
20408       do j=-1,1
20409        vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20410        vectube(1)=vectube(1)+boxxsize*j
20411        vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20412        vectube(2)=vectube(2)+boxysize*j
20413        vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
20414        vectube(3)=vectube(3)+boxzsize*j
20415
20416
20417        xminact=dabs(vectube(1)-tubecenter(1))
20418        yminact=dabs(vectube(2)-tubecenter(2))
20419        zminact=dabs(vectube(3)-tubecenter(3))
20420
20421          if (xmin.gt.xminact) then
20422           xmin=xminact
20423           xtemp=vectube(1)
20424          endif
20425          if (ymin.gt.yminact) then
20426            ymin=yminact
20427            ytemp=vectube(2)
20428           endif
20429          if (zmin.gt.zminact) then
20430            zmin=zminact
20431            ztemp=vectube(3)
20432           endif
20433        enddo
20434       vectube(1)=xtemp
20435       vectube(2)=ytemp
20436       vectube(3)=ztemp
20437
20438       vectube(1)=vectube(1)-tubecenter(1)
20439       vectube(2)=vectube(2)-tubecenter(2)
20440       vectube(3)=vectube(3)-tubecenter(3)
20441
20442 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20443 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20444 !C as the tube is infinity we do not calculate the Z-vector use of Z
20445 !C as chosen axis
20446 !C      vectube(3)=0.0d0
20447 !C now calculte the distance
20448        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20449 !C now normalize vector
20450       vectube(1)=vectube(1)/tub_r
20451       vectube(2)=vectube(2)/tub_r
20452       vectube(3)=vectube(3)/tub_r
20453 !C calculte rdiffrence between r and r0
20454       rdiff=tub_r-tubeR0
20455 !C and its 6 power
20456       rdiff6=rdiff**6.0d0
20457 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20458        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
20459 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
20460 !C       print *,rdiff,rdiff6,pep_aa_tube
20461 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20462 !C now we calculate gradient
20463        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
20464           6.0d0*pep_bb_tube)/rdiff6/rdiff
20465 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
20466 !C     &rdiff,fac
20467        if (acavtubpep.eq.0.0d0) then
20468 !C go to 667
20469        enecavtube(i)=0.0
20470        faccav=0.0
20471        else
20472        denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
20473        enecavtube(i)=  &
20474       (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
20475       /denominator
20476        enecavtube(i)=0.0
20477        faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
20478       *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
20479       +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
20480       /denominator**2.0d0
20481 !C         faccav=0.0
20482 !C         fac=fac+faccav
20483 !C 667     continue
20484        endif
20485         if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
20486       do j=1,3
20487       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
20488       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
20489       enddo
20490       enddo
20491
20492        do i=itube_start,itube_end
20493       enecavtube(i)=0.0d0
20494 !C Lets not jump over memory as we use many times iti
20495        iti=itype(i,1)
20496 !C lets ommit dummy atoms for now
20497        if ((iti.eq.ntyp1) &
20498 !C in UNRES uncomment the line below as GLY has no side-chain...
20499 !C      .or.(iti.eq.10)
20500        ) cycle
20501       xmin=boxxsize
20502       ymin=boxysize
20503       zmin=boxzsize
20504       do j=-1,1
20505        vectube(1)=dmod((c(1,i+nres)),boxxsize)
20506        vectube(1)=vectube(1)+boxxsize*j
20507        vectube(2)=dmod((c(2,i+nres)),boxysize)
20508        vectube(2)=vectube(2)+boxysize*j
20509        vectube(3)=dmod((c(3,i+nres)),boxzsize)
20510        vectube(3)=vectube(3)+boxzsize*j
20511
20512
20513        xminact=dabs(vectube(1)-tubecenter(1))
20514        yminact=dabs(vectube(2)-tubecenter(2))
20515        zminact=dabs(vectube(3)-tubecenter(3))
20516
20517          if (xmin.gt.xminact) then
20518           xmin=xminact
20519           xtemp=vectube(1)
20520          endif
20521          if (ymin.gt.yminact) then
20522            ymin=yminact
20523            ytemp=vectube(2)
20524           endif
20525          if (zmin.gt.zminact) then
20526            zmin=zminact
20527            ztemp=vectube(3)
20528           endif
20529        enddo
20530       vectube(1)=xtemp
20531       vectube(2)=ytemp
20532       vectube(3)=ztemp
20533
20534 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
20535 !C     &     tubecenter(2)
20536       vectube(1)=vectube(1)-tubecenter(1)
20537       vectube(2)=vectube(2)-tubecenter(2)
20538       vectube(3)=vectube(3)-tubecenter(3)
20539 !C now calculte the distance
20540        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20541 !C now normalize vector
20542       vectube(1)=vectube(1)/tub_r
20543       vectube(2)=vectube(2)/tub_r
20544       vectube(3)=vectube(3)/tub_r
20545
20546 !C calculte rdiffrence between r and r0
20547       rdiff=tub_r-tubeR0
20548 !C and its 6 power
20549       rdiff6=rdiff**6.0d0
20550        sc_aa_tube=sc_aa_tube_par(iti)
20551        sc_bb_tube=sc_bb_tube_par(iti)
20552        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20553 !C       enetube(i+nres)=0.0d0
20554 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20555 !C now we calculate gradient
20556        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
20557           6.0d0*sc_bb_tube/rdiff6/rdiff
20558 !C       fac=0.0
20559 !C now direction of gg_tube vector
20560 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
20561        if (acavtub(iti).eq.0.0d0) then
20562 !C go to 667
20563        enecavtube(i+nres)=0.0d0
20564        faccav=0.0d0
20565        else
20566        denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
20567        enecavtube(i+nres)=   &
20568       (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
20569       /denominator
20570 !C         enecavtube(i)=0.0
20571        faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
20572       *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
20573       +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
20574       /denominator**2.0d0
20575 !C         faccav=0.0
20576        fac=fac+faccav
20577 !C 667     continue
20578        endif
20579 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
20580 !C     &   enecavtube(i),faccav
20581 !C         print *,"licz=",
20582 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
20583 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
20584        do j=1,3
20585         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20586         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20587        enddo
20588         if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
20589       enddo
20590
20591
20592
20593       do i=itube_start,itube_end
20594         Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
20595        +enecavtube(i+nres)
20596       enddo
20597 !        do i=1,20
20598 !         print *,"begin", i,"a"
20599 !         do r=1,10000
20600 !          rdiff=r/100.0d0
20601 !          rdiff6=rdiff**6.0d0
20602 !          sc_aa_tube=sc_aa_tube_par(i)
20603 !          sc_bb_tube=sc_bb_tube_par(i)
20604 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20605 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
20606 !          enecavtube(i)=   &
20607 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
20608 !         /denominator
20609
20610 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
20611 !         enddo
20612 !         print *,"end",i,"a"
20613 !        enddo
20614 !C        print *,"ETUBE", etube
20615       return
20616       end subroutine calcnano
20617
20618 !===============================================
20619 !--------------------------------------------------------------------------------
20620 !C first for shielding is setting of function of side-chains
20621
20622        subroutine set_shield_fac2
20623        real(kind=8) :: div77_81=0.974996043d0, &
20624       div4_81=0.2222222222d0
20625        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
20626        scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
20627        short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
20628        sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
20629 !C the vector between center of side_chain and peptide group
20630        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
20631        pept_group,costhet_grad,cosphi_grad_long, &
20632        cosphi_grad_loc,pep_side_norm,side_calf_norm, &
20633        sh_frac_dist_grad,pep_side
20634       integer i,j,k
20635 !C      write(2,*) "ivec",ivec_start,ivec_end
20636       do i=1,nres
20637       fac_shield(i)=0.0d0
20638       ishield_list(i)=0
20639       do j=1,3
20640       grad_shield(j,i)=0.0d0
20641       enddo
20642       enddo
20643       do i=ivec_start,ivec_end
20644 !C      do i=1,nres-1
20645 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20646 !      ishield_list(i)=0
20647       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20648 !Cif there two consequtive dummy atoms there is no peptide group between them
20649 !C the line below has to be changed for FGPROC>1
20650       VolumeTotal=0.0
20651       do k=1,nres
20652        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
20653        dist_pep_side=0.0
20654        dist_side_calf=0.0
20655        do j=1,3
20656 !C first lets set vector conecting the ithe side-chain with kth side-chain
20657       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
20658 !C      pep_side(j)=2.0d0
20659 !C and vector conecting the side-chain with its proper calfa
20660       side_calf(j)=c(j,k+nres)-c(j,k)
20661 !C      side_calf(j)=2.0d0
20662       pept_group(j)=c(j,i)-c(j,i+1)
20663 !C lets have their lenght
20664       dist_pep_side=pep_side(j)**2+dist_pep_side
20665       dist_side_calf=dist_side_calf+side_calf(j)**2
20666       dist_pept_group=dist_pept_group+pept_group(j)**2
20667       enddo
20668        dist_pep_side=sqrt(dist_pep_side)
20669        dist_pept_group=sqrt(dist_pept_group)
20670        dist_side_calf=sqrt(dist_side_calf)
20671       do j=1,3
20672       pep_side_norm(j)=pep_side(j)/dist_pep_side
20673       side_calf_norm(j)=dist_side_calf
20674       enddo
20675 !C now sscale fraction
20676        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
20677 !       print *,buff_shield,"buff",sh_frac_dist
20678 !C now sscale
20679       if (sh_frac_dist.le.0.0) cycle
20680 !C        print *,ishield_list(i),i
20681 !C If we reach here it means that this side chain reaches the shielding sphere
20682 !C Lets add him to the list for gradient
20683       ishield_list(i)=ishield_list(i)+1
20684 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
20685 !C this list is essential otherwise problem would be O3
20686       shield_list(ishield_list(i),i)=k
20687 !C Lets have the sscale value
20688       if (sh_frac_dist.gt.1.0) then
20689        scale_fac_dist=1.0d0
20690        do j=1,3
20691        sh_frac_dist_grad(j)=0.0d0
20692        enddo
20693       else
20694        scale_fac_dist=-sh_frac_dist*sh_frac_dist &
20695                   *(2.0d0*sh_frac_dist-3.0d0)
20696        fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
20697                    /dist_pep_side/buff_shield*0.5d0
20698        do j=1,3
20699        sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
20700 !C         sh_frac_dist_grad(j)=0.0d0
20701 !C         scale_fac_dist=1.0d0
20702 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
20703 !C     &                    sh_frac_dist_grad(j)
20704        enddo
20705       endif
20706 !C this is what is now we have the distance scaling now volume...
20707       short=short_r_sidechain(itype(k,1))
20708       long=long_r_sidechain(itype(k,1))
20709       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
20710       sinthet=short/dist_pep_side*costhet
20711 !      print *,"SORT",short,long,sinthet,costhet
20712 !C now costhet_grad
20713 !C       costhet=0.6d0
20714 !C       sinthet=0.8
20715        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
20716 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
20717 !C     &             -short/dist_pep_side**2/costhet)
20718 !C       costhet_fac=0.0d0
20719        do j=1,3
20720        costhet_grad(j)=costhet_fac*pep_side(j)
20721        enddo
20722 !C remember for the final gradient multiply costhet_grad(j)
20723 !C for side_chain by factor -2 !
20724 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
20725 !C pep_side0pept_group is vector multiplication
20726       pep_side0pept_group=0.0d0
20727       do j=1,3
20728       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
20729       enddo
20730       cosalfa=(pep_side0pept_group/ &
20731       (dist_pep_side*dist_side_calf))
20732       fac_alfa_sin=1.0d0-cosalfa**2
20733       fac_alfa_sin=dsqrt(fac_alfa_sin)
20734       rkprim=fac_alfa_sin*(long-short)+short
20735 !C      rkprim=short
20736
20737 !C now costhet_grad
20738        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
20739 !C       cosphi=0.6
20740        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
20741        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
20742          dist_pep_side**2)
20743 !C       sinphi=0.8
20744        do j=1,3
20745        cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
20746       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20747       *(long-short)/fac_alfa_sin*cosalfa/ &
20748       ((dist_pep_side*dist_side_calf))* &
20749       ((side_calf(j))-cosalfa* &
20750       ((pep_side(j)/dist_pep_side)*dist_side_calf))
20751 !C       cosphi_grad_long(j)=0.0d0
20752       cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20753       *(long-short)/fac_alfa_sin*cosalfa &
20754       /((dist_pep_side*dist_side_calf))* &
20755       (pep_side(j)- &
20756       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
20757 !C       cosphi_grad_loc(j)=0.0d0
20758        enddo
20759 !C      print *,sinphi,sinthet
20760       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
20761                    /VSolvSphere_div
20762 !C     &                    *wshield
20763 !C now the gradient...
20764       do j=1,3
20765       grad_shield(j,i)=grad_shield(j,i) &
20766 !C gradient po skalowaniu
20767                  +(sh_frac_dist_grad(j)*VofOverlap &
20768 !C  gradient po costhet
20769           +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
20770       (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
20771           sinphi/sinthet*costhet*costhet_grad(j) &
20772          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20773       )*wshield
20774 !C grad_shield_side is Cbeta sidechain gradient
20775       grad_shield_side(j,ishield_list(i),i)=&
20776            (sh_frac_dist_grad(j)*-2.0d0&
20777            *VofOverlap&
20778           -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20779        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
20780           sinphi/sinthet*costhet*costhet_grad(j)&
20781          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20782           )*wshield
20783 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
20784 !            sinphi/sinthet,&
20785 !           +sinthet/sinphi,"HERE"
20786        grad_shield_loc(j,ishield_list(i),i)=   &
20787           scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20788       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
20789           sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
20790            ))&
20791            *wshield
20792 !         print *,grad_shield_loc(j,ishield_list(i),i)
20793       enddo
20794       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
20795       enddo
20796       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
20797
20798 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
20799       enddo
20800       return
20801       end subroutine set_shield_fac2
20802 !----------------------------------------------------------------------------
20803 ! SOUBROUTINE FOR AFM
20804        subroutine AFMvel(Eafmforce)
20805        use MD_data, only:totTafm
20806       real(kind=8),dimension(3) :: diffafm
20807       real(kind=8) :: afmdist,Eafmforce
20808        integer :: i
20809 !C Only for check grad COMMENT if not used for checkgrad
20810 !C      totT=3.0d0
20811 !C--------------------------------------------------------
20812 !C      print *,"wchodze"
20813       afmdist=0.0d0
20814       Eafmforce=0.0d0
20815       do i=1,3
20816       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20817       afmdist=afmdist+diffafm(i)**2
20818       enddo
20819       afmdist=dsqrt(afmdist)
20820 !      totTafm=3.0
20821       Eafmforce=0.5d0*forceAFMconst &
20822       *(distafminit+totTafm*velAFMconst-afmdist)**2
20823 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
20824       do i=1,3
20825       gradafm(i,afmend-1)=-forceAFMconst* &
20826        (distafminit+totTafm*velAFMconst-afmdist) &
20827        *diffafm(i)/afmdist
20828       gradafm(i,afmbeg-1)=forceAFMconst* &
20829       (distafminit+totTafm*velAFMconst-afmdist) &
20830       *diffafm(i)/afmdist
20831       enddo
20832 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
20833       return
20834       end subroutine AFMvel
20835 !---------------------------------------------------------
20836        subroutine AFMforce(Eafmforce)
20837
20838       real(kind=8),dimension(3) :: diffafm
20839 !      real(kind=8) ::afmdist
20840       real(kind=8) :: afmdist,Eafmforce
20841       integer :: i
20842       afmdist=0.0d0
20843       Eafmforce=0.0d0
20844       do i=1,3
20845       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20846       afmdist=afmdist+diffafm(i)**2
20847       enddo
20848       afmdist=dsqrt(afmdist)
20849 !      print *,afmdist,distafminit
20850       Eafmforce=-forceAFMconst*(afmdist-distafminit)
20851       do i=1,3
20852       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
20853       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
20854       enddo
20855 !C      print *,'AFM',Eafmforce
20856       return
20857       end subroutine AFMforce
20858
20859 !-----------------------------------------------------------------------------
20860 #ifdef WHAM
20861       subroutine read_ssHist
20862 !      implicit none
20863 !      Includes
20864 !      include 'DIMENSIONS'
20865 !      include "DIMENSIONS.FREE"
20866 !      include 'COMMON.FREE'
20867 !     Local variables
20868       integer :: i,j
20869       character(len=80) :: controlcard
20870
20871       do i=1,dyn_nssHist
20872       call card_concat(controlcard,.true.)
20873       read(controlcard,*) &
20874            dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
20875       enddo
20876
20877       return
20878       end subroutine read_ssHist
20879 #endif
20880 !-----------------------------------------------------------------------------
20881       integer function indmat(i,j)
20882 !el
20883 ! get the position of the jth ijth fragment of the chain coordinate system
20884 ! in the fromto array.
20885       integer :: i,j
20886
20887       indmat=((2*(nres-2)-i)*(i-1))/2+j-1
20888       return
20889       end function indmat
20890 !-----------------------------------------------------------------------------
20891       real(kind=8) function sigm(x)
20892 !el
20893        real(kind=8) :: x
20894       sigm=0.25d0*x
20895       return
20896       end function sigm
20897 !-----------------------------------------------------------------------------
20898 !-----------------------------------------------------------------------------
20899       subroutine alloc_ener_arrays
20900 !EL Allocation of arrays used by module energy
20901       use MD_data, only: mset
20902 !el local variables
20903       integer :: i,j
20904
20905       if(nres.lt.100) then
20906       maxconts=10*nres
20907       elseif(nres.lt.200) then
20908       maxconts=10*nres      ! Max. number of contacts per residue
20909       else
20910       maxconts=10*nres ! (maxconts=maxres/4)
20911       endif
20912       maxcont=100*nres      ! Max. number of SC contacts
20913       maxvar=6*nres      ! Max. number of variables
20914 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20915       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20916 !----------------------
20917 ! arrays in subroutine init_int_table
20918 !el#ifdef MPI
20919 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
20920 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
20921 !el#endif
20922       allocate(nint_gr(nres))
20923       allocate(nscp_gr(nres))
20924       allocate(ielstart(nres))
20925       allocate(ielend(nres))
20926 !(maxres)
20927       allocate(istart(nres,maxint_gr))
20928       allocate(iend(nres,maxint_gr))
20929 !(maxres,maxint_gr)
20930       allocate(iscpstart(nres,maxint_gr))
20931       allocate(iscpend(nres,maxint_gr))
20932 !(maxres,maxint_gr)
20933       allocate(ielstart_vdw(nres))
20934       allocate(ielend_vdw(nres))
20935 !(maxres)
20936       allocate(nint_gr_nucl(nres))
20937       allocate(nscp_gr_nucl(nres))
20938       allocate(ielstart_nucl(nres))
20939       allocate(ielend_nucl(nres))
20940 !(maxres)
20941       allocate(istart_nucl(nres,maxint_gr))
20942       allocate(iend_nucl(nres,maxint_gr))
20943 !(maxres,maxint_gr)
20944       allocate(iscpstart_nucl(nres,maxint_gr))
20945       allocate(iscpend_nucl(nres,maxint_gr))
20946 !(maxres,maxint_gr)
20947       allocate(ielstart_vdw_nucl(nres))
20948       allocate(ielend_vdw_nucl(nres))
20949
20950       allocate(lentyp(0:nfgtasks-1))
20951 !(0:maxprocs-1)
20952 !----------------------
20953 ! commom.contacts
20954 !      common /contacts/
20955       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
20956       allocate(icont(2,maxcont))
20957 !(2,maxcont)
20958 !      common /contacts1/
20959       allocate(num_cont(0:nres+4))
20960 !(maxres)
20961       allocate(jcont(maxconts,nres))
20962 !(maxconts,maxres)
20963       allocate(facont(maxconts,nres))
20964 !(maxconts,maxres)
20965       allocate(gacont(3,maxconts,nres))
20966 !(3,maxconts,maxres)
20967 !      common /contacts_hb/
20968       allocate(gacontp_hb1(3,maxconts,nres))
20969       allocate(gacontp_hb2(3,maxconts,nres))
20970       allocate(gacontp_hb3(3,maxconts,nres))
20971       allocate(gacontm_hb1(3,maxconts,nres))
20972       allocate(gacontm_hb2(3,maxconts,nres))
20973       allocate(gacontm_hb3(3,maxconts,nres))
20974       allocate(gacont_hbr(3,maxconts,nres))
20975       allocate(grij_hb_cont(3,maxconts,nres))
20976         !(3,maxconts,maxres)
20977       allocate(facont_hb(maxconts,nres))
20978
20979       allocate(ees0p(maxconts,nres))
20980       allocate(ees0m(maxconts,nres))
20981       allocate(d_cont(maxconts,nres))
20982       allocate(ees0plist(maxconts,nres))
20983
20984 !(maxconts,maxres)
20985       allocate(num_cont_hb(nres))
20986 !(maxres)
20987       allocate(jcont_hb(maxconts,nres))
20988 !(maxconts,maxres)
20989 !      common /rotat/
20990       allocate(Ug(2,2,nres))
20991       allocate(Ugder(2,2,nres))
20992       allocate(Ug2(2,2,nres))
20993       allocate(Ug2der(2,2,nres))
20994 !(2,2,maxres)
20995       allocate(obrot(2,nres))
20996       allocate(obrot2(2,nres))
20997       allocate(obrot_der(2,nres))
20998       allocate(obrot2_der(2,nres))
20999 !(2,maxres)
21000 !      common /precomp1/
21001       allocate(mu(2,nres))
21002       allocate(muder(2,nres))
21003       allocate(Ub2(2,nres))
21004       Ub2(1,:)=0.0d0
21005       Ub2(2,:)=0.0d0
21006       allocate(Ub2der(2,nres))
21007       allocate(Ctobr(2,nres))
21008       allocate(Ctobrder(2,nres))
21009       allocate(Dtobr2(2,nres))
21010       allocate(Dtobr2der(2,nres))
21011 !(2,maxres)
21012       allocate(EUg(2,2,nres))
21013       allocate(EUgder(2,2,nres))
21014       allocate(CUg(2,2,nres))
21015       allocate(CUgder(2,2,nres))
21016       allocate(DUg(2,2,nres))
21017       allocate(Dugder(2,2,nres))
21018       allocate(DtUg2(2,2,nres))
21019       allocate(DtUg2der(2,2,nres))
21020 !(2,2,maxres)
21021 !      common /precomp2/
21022       allocate(Ug2Db1t(2,nres))
21023       allocate(Ug2Db1tder(2,nres))
21024       allocate(CUgb2(2,nres))
21025       allocate(CUgb2der(2,nres))
21026 !(2,maxres)
21027       allocate(EUgC(2,2,nres))
21028       allocate(EUgCder(2,2,nres))
21029       allocate(EUgD(2,2,nres))
21030       allocate(EUgDder(2,2,nres))
21031       allocate(DtUg2EUg(2,2,nres))
21032       allocate(Ug2DtEUg(2,2,nres))
21033 !(2,2,maxres)
21034       allocate(Ug2DtEUgder(2,2,2,nres))
21035       allocate(DtUg2EUgder(2,2,2,nres))
21036 !(2,2,2,maxres)
21037       allocate(b1(2,nres))      !(2,-maxtor:maxtor)
21038       allocate(b2(2,nres))      !(2,-maxtor:maxtor)
21039       allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor)
21040       allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor)
21041
21042       allocate(ctilde(2,2,nres))
21043       allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor)
21044       allocate(gtb1(2,nres))
21045       allocate(gtb2(2,nres))
21046       allocate(cc(2,2,nres))
21047       allocate(dd(2,2,nres))
21048       allocate(ee(2,2,nres))
21049       allocate(gtcc(2,2,nres))
21050       allocate(gtdd(2,2,nres))
21051       allocate(gtee(2,2,nres))
21052       allocate(gUb2(2,nres))
21053       allocate(gteUg(2,2,nres))
21054
21055 !      common /rotat_old/
21056       allocate(costab(nres))
21057       allocate(sintab(nres))
21058       allocate(costab2(nres))
21059       allocate(sintab2(nres))
21060 !(maxres)
21061 !      common /dipmat/
21062       allocate(a_chuj(2,2,maxconts,nres))
21063 !(2,2,maxconts,maxres)(maxconts=maxres/4)
21064       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
21065 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
21066 !      common /contdistrib/
21067       allocate(ncont_sent(nres))
21068       allocate(ncont_recv(nres))
21069
21070       allocate(iat_sent(nres))
21071 !(maxres)
21072       allocate(iint_sent(4,nres,nres))
21073       allocate(iint_sent_local(4,nres,nres))
21074 !(4,maxres,maxres)
21075       allocate(iturn3_sent(4,0:nres+4))
21076       allocate(iturn4_sent(4,0:nres+4))
21077       allocate(iturn3_sent_local(4,nres))
21078       allocate(iturn4_sent_local(4,nres))
21079 !(4,maxres)
21080       allocate(itask_cont_from(0:nfgtasks-1))
21081       allocate(itask_cont_to(0:nfgtasks-1))
21082 !(0:max_fg_procs-1)
21083
21084
21085
21086 !----------------------
21087 ! commom.deriv;
21088 !      common /derivat/
21089       allocate(dcdv(6,maxdim))
21090       allocate(dxdv(6,maxdim))
21091 !(6,maxdim)
21092       allocate(dxds(6,nres))
21093 !(6,maxres)
21094       allocate(gradx(3,-1:nres,0:2))
21095       allocate(gradc(3,-1:nres,0:2))
21096 !(3,maxres,2)
21097       allocate(gvdwx(3,-1:nres))
21098       allocate(gvdwc(3,-1:nres))
21099       allocate(gelc(3,-1:nres))
21100       allocate(gelc_long(3,-1:nres))
21101       allocate(gvdwpp(3,-1:nres))
21102       allocate(gvdwc_scpp(3,-1:nres))
21103       allocate(gradx_scp(3,-1:nres))
21104       allocate(gvdwc_scp(3,-1:nres))
21105       allocate(ghpbx(3,-1:nres))
21106       allocate(ghpbc(3,-1:nres))
21107       allocate(gradcorr(3,-1:nres))
21108       allocate(gradcorr_long(3,-1:nres))
21109       allocate(gradcorr5_long(3,-1:nres))
21110       allocate(gradcorr6_long(3,-1:nres))
21111       allocate(gcorr6_turn_long(3,-1:nres))
21112       allocate(gradxorr(3,-1:nres))
21113       allocate(gradcorr5(3,-1:nres))
21114       allocate(gradcorr6(3,-1:nres))
21115       allocate(gliptran(3,-1:nres))
21116       allocate(gliptranc(3,-1:nres))
21117       allocate(gliptranx(3,-1:nres))
21118       allocate(gshieldx(3,-1:nres))
21119       allocate(gshieldc(3,-1:nres))
21120       allocate(gshieldc_loc(3,-1:nres))
21121       allocate(gshieldx_ec(3,-1:nres))
21122       allocate(gshieldc_ec(3,-1:nres))
21123       allocate(gshieldc_loc_ec(3,-1:nres))
21124       allocate(gshieldx_t3(3,-1:nres))
21125       allocate(gshieldc_t3(3,-1:nres))
21126       allocate(gshieldc_loc_t3(3,-1:nres))
21127       allocate(gshieldx_t4(3,-1:nres))
21128       allocate(gshieldc_t4(3,-1:nres))
21129       allocate(gshieldc_loc_t4(3,-1:nres))
21130       allocate(gshieldx_ll(3,-1:nres))
21131       allocate(gshieldc_ll(3,-1:nres))
21132       allocate(gshieldc_loc_ll(3,-1:nres))
21133       allocate(grad_shield(3,-1:nres))
21134       allocate(gg_tube_sc(3,-1:nres))
21135       allocate(gg_tube(3,-1:nres))
21136       allocate(gradafm(3,-1:nres))
21137       allocate(gradb_nucl(3,-1:nres))
21138       allocate(gradbx_nucl(3,-1:nres))
21139       allocate(gvdwpsb1(3,-1:nres))
21140       allocate(gelpp(3,-1:nres))
21141       allocate(gvdwpsb(3,-1:nres))
21142       allocate(gelsbc(3,-1:nres))
21143       allocate(gelsbx(3,-1:nres))
21144       allocate(gvdwsbx(3,-1:nres))
21145       allocate(gvdwsbc(3,-1:nres))
21146       allocate(gsbloc(3,-1:nres))
21147       allocate(gsblocx(3,-1:nres))
21148       allocate(gradcorr_nucl(3,-1:nres))
21149       allocate(gradxorr_nucl(3,-1:nres))
21150       allocate(gradcorr3_nucl(3,-1:nres))
21151       allocate(gradxorr3_nucl(3,-1:nres))
21152       allocate(gvdwpp_nucl(3,-1:nres))
21153       allocate(gradpepcat(3,-1:nres))
21154       allocate(gradpepcatx(3,-1:nres))
21155       allocate(gradcatcat(3,-1:nres))
21156       allocate(gradnuclcat(3,-1:nres))
21157       allocate(gradnuclcatx(3,-1:nres))
21158 !(3,maxres)
21159       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
21160       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
21161 ! grad for shielding surroing
21162       allocate(gloc(0:maxvar,0:2))
21163       allocate(gloc_x(0:maxvar,2))
21164 !(maxvar,2)
21165       allocate(gel_loc(3,-1:nres))
21166       allocate(gel_loc_long(3,-1:nres))
21167       allocate(gcorr3_turn(3,-1:nres))
21168       allocate(gcorr4_turn(3,-1:nres))
21169       allocate(gcorr6_turn(3,-1:nres))
21170       allocate(gradb(3,-1:nres))
21171       allocate(gradbx(3,-1:nres))
21172 !(3,maxres)
21173       allocate(gel_loc_loc(maxvar))
21174       allocate(gel_loc_turn3(maxvar))
21175       allocate(gel_loc_turn4(maxvar))
21176       allocate(gel_loc_turn6(maxvar))
21177       allocate(gcorr_loc(maxvar))
21178       allocate(g_corr5_loc(maxvar))
21179       allocate(g_corr6_loc(maxvar))
21180 !(maxvar)
21181       allocate(gsccorc(3,-1:nres))
21182       allocate(gsccorx(3,-1:nres))
21183 !(3,maxres)
21184       allocate(gsccor_loc(-1:nres))
21185 !(maxres)
21186       allocate(gvdwx_scbase(3,-1:nres))
21187       allocate(gvdwc_scbase(3,-1:nres))
21188       allocate(gvdwx_pepbase(3,-1:nres))
21189       allocate(gvdwc_pepbase(3,-1:nres))
21190       allocate(gvdwx_scpho(3,-1:nres))
21191       allocate(gvdwc_scpho(3,-1:nres))
21192       allocate(gvdwc_peppho(3,-1:nres))
21193
21194       allocate(dtheta(3,2,-1:nres))
21195 !(3,2,maxres)
21196       allocate(gscloc(3,-1:nres))
21197       allocate(gsclocx(3,-1:nres))
21198 !(3,maxres)
21199       allocate(dphi(3,3,-1:nres))
21200       allocate(dalpha(3,3,-1:nres))
21201       allocate(domega(3,3,-1:nres))
21202 !(3,3,maxres)
21203 !      common /deriv_scloc/
21204       allocate(dXX_C1tab(3,nres))
21205       allocate(dYY_C1tab(3,nres))
21206       allocate(dZZ_C1tab(3,nres))
21207       allocate(dXX_Ctab(3,nres))
21208       allocate(dYY_Ctab(3,nres))
21209       allocate(dZZ_Ctab(3,nres))
21210       allocate(dXX_XYZtab(3,nres))
21211       allocate(dYY_XYZtab(3,nres))
21212       allocate(dZZ_XYZtab(3,nres))
21213 !(3,maxres)
21214 !      common /mpgrad/
21215       allocate(jgrad_start(nres))
21216       allocate(jgrad_end(nres))
21217 !(maxres)
21218 !----------------------
21219
21220 !      common /indices/
21221       allocate(ibond_displ(0:nfgtasks-1))
21222       allocate(ibond_count(0:nfgtasks-1))
21223       allocate(ithet_displ(0:nfgtasks-1))
21224       allocate(ithet_count(0:nfgtasks-1))
21225       allocate(iphi_displ(0:nfgtasks-1))
21226       allocate(iphi_count(0:nfgtasks-1))
21227       allocate(iphi1_displ(0:nfgtasks-1))
21228       allocate(iphi1_count(0:nfgtasks-1))
21229       allocate(ivec_displ(0:nfgtasks-1))
21230       allocate(ivec_count(0:nfgtasks-1))
21231       allocate(iset_displ(0:nfgtasks-1))
21232       allocate(iset_count(0:nfgtasks-1))
21233       allocate(iint_count(0:nfgtasks-1))
21234       allocate(iint_displ(0:nfgtasks-1))
21235 !(0:max_fg_procs-1)
21236 !----------------------
21237 ! common.MD
21238 !      common /mdgrad/
21239       allocate(gcart(3,-1:nres))
21240       allocate(gxcart(3,-1:nres))
21241 !(3,0:MAXRES)
21242       allocate(gradcag(3,-1:nres))
21243       allocate(gradxag(3,-1:nres))
21244 !(3,MAXRES)
21245 !      common /back_constr/
21246 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
21247       allocate(dutheta(nres))
21248       allocate(dugamma(nres))
21249 !(maxres)
21250       allocate(duscdiff(3,-1:nres))
21251       allocate(duscdiffx(3,-1:nres))
21252 !(3,maxres)
21253 !el i io:read_fragments
21254 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
21255 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
21256 !      common /qmeas/
21257 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
21258 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
21259       allocate(mset(0:nprocs))  !(maxprocs/20)
21260       mset(:)=0
21261 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
21262 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
21263       allocate(dUdconst(3,0:nres))
21264       allocate(dUdxconst(3,0:nres))
21265       allocate(dqwol(3,0:nres))
21266       allocate(dxqwol(3,0:nres))
21267 !(3,0:MAXRES)
21268 !----------------------
21269 ! common.sbridge
21270 !      common /sbridge/ in io_common: read_bridge
21271 !el    allocate((:),allocatable :: iss      !(maxss)
21272 !      common /links/  in io_common: read_bridge
21273 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
21274 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
21275 !      common /dyn_ssbond/
21276 ! and side-chain vectors in theta or phi.
21277       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
21278 !(maxres,maxres)
21279 !      do i=1,nres
21280 !        do j=i+1,nres
21281       dyn_ssbond_ij(:,:)=1.0d300
21282 !        enddo
21283 !      enddo
21284
21285 !      if (nss.gt.0) then
21286       allocate(idssb(maxdim),jdssb(maxdim))
21287 !        allocate(newihpb(nss),newjhpb(nss))
21288 !(maxdim)
21289 !      endif
21290       allocate(ishield_list(-1:nres))
21291       allocate(shield_list(maxcontsshi,-1:nres))
21292       allocate(dyn_ss_mask(nres))
21293       allocate(fac_shield(-1:nres))
21294       allocate(enetube(nres*2))
21295       allocate(enecavtube(nres*2))
21296
21297 !(maxres)
21298       dyn_ss_mask(:)=.false.
21299 !----------------------
21300 ! common.sccor
21301 ! Parameters of the SCCOR term
21302 !      common/sccor/
21303 !el in io_conf: parmread
21304 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
21305 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
21306 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
21307 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
21308 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
21309 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
21310 !      allocate(vlor1sccor(maxterm_sccor,20,20))
21311 !      allocate(vlor2sccor(maxterm_sccor,20,20))
21312 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
21313 !----------------
21314       allocate(gloc_sc(3,0:2*nres,0:10))
21315 !(3,0:maxres2,10)maxres2=2*maxres
21316       allocate(dcostau(3,3,3,2*nres))
21317       allocate(dsintau(3,3,3,2*nres))
21318       allocate(dtauangle(3,3,3,2*nres))
21319       allocate(dcosomicron(3,3,3,2*nres))
21320       allocate(domicron(3,3,3,2*nres))
21321 !(3,3,3,maxres2)maxres2=2*maxres
21322 !----------------------
21323 ! common.var
21324 !      common /restr/
21325       allocate(varall(maxvar))
21326 !(maxvar)(maxvar=6*maxres)
21327       allocate(mask_theta(nres))
21328       allocate(mask_phi(nres))
21329       allocate(mask_side(nres))
21330 !(maxres)
21331 !----------------------
21332 ! common.vectors
21333 !      common /vectors/
21334       allocate(uy(3,nres))
21335       allocate(uz(3,nres))
21336 !(3,maxres)
21337       allocate(uygrad(3,3,2,nres))
21338       allocate(uzgrad(3,3,2,nres))
21339 !(3,3,2,maxres)
21340 ! allocateion of lists JPRDLA
21341       allocate(newcontlistppi(300*nres))
21342       allocate(newcontlistscpi(350*nres))
21343       allocate(newcontlisti(300*nres))
21344       allocate(newcontlistppj(300*nres))
21345       allocate(newcontlistscpj(350*nres))
21346       allocate(newcontlistj(300*nres))
21347
21348       return
21349       end subroutine alloc_ener_arrays
21350 !-----------------------------------------------------------------
21351       subroutine ebond_nucl(estr_nucl)
21352 !c
21353 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
21354 !c
21355
21356       real(kind=8),dimension(3) :: u,ud
21357       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
21358       real(kind=8) :: estr_nucl,diff
21359       integer :: iti,i,j,k,nbi
21360       estr_nucl=0.0d0
21361 !C      print *,"I enter ebond"
21362       if (energy_dec) &
21363       write (iout,*) "ibondp_start,ibondp_end",&
21364        ibondp_nucl_start,ibondp_nucl_end
21365       do i=ibondp_nucl_start,ibondp_nucl_end
21366       if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
21367        itype(i,2).eq.ntyp1_molec(2)) cycle
21368 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
21369 !          do j=1,3
21370 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
21371 !     &      *dc(j,i-1)/vbld(i)
21372 !          enddo
21373 !          if (energy_dec) write(iout,*)
21374 !     &       "estr1",i,vbld(i),distchainmax,
21375 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
21376
21377         diff = vbld(i)-vbldp0_nucl
21378         if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
21379         vbldp0_nucl,diff,AKP_nucl*diff*diff
21380         estr_nucl=estr_nucl+diff*diff
21381 !          print *,estr_nucl
21382         do j=1,3
21383           gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
21384         enddo
21385 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
21386       enddo
21387       estr_nucl=0.5d0*AKP_nucl*estr_nucl
21388 !      print *,"partial sum", estr_nucl,AKP_nucl
21389
21390       if (energy_dec) &
21391       write (iout,*) "ibondp_start,ibondp_end",&
21392        ibond_nucl_start,ibond_nucl_end
21393
21394       do i=ibond_nucl_start,ibond_nucl_end
21395 !C        print *, "I am stuck",i
21396       iti=itype(i,2)
21397       if (iti.eq.ntyp1_molec(2)) cycle
21398         nbi=nbondterm_nucl(iti)
21399 !C        print *,iti,nbi
21400         if (nbi.eq.1) then
21401           diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
21402
21403           if (energy_dec) &
21404          write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
21405          AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
21406           estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
21407 !            print *,estr_nucl
21408           do j=1,3
21409             gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
21410           enddo
21411         else
21412           do j=1,nbi
21413             diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
21414             ud(j)=aksc_nucl(j,iti)*diff
21415             u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
21416           enddo
21417           uprod=u(1)
21418           do j=2,nbi
21419             uprod=uprod*u(j)
21420           enddo
21421           usum=0.0d0
21422           usumsqder=0.0d0
21423           do j=1,nbi
21424             uprod1=1.0d0
21425             uprod2=1.0d0
21426             do k=1,nbi
21427             if (k.ne.j) then
21428               uprod1=uprod1*u(k)
21429               uprod2=uprod2*u(k)*u(k)
21430             endif
21431             enddo
21432             usum=usum+uprod1
21433             usumsqder=usumsqder+ud(j)*uprod2
21434           enddo
21435           estr_nucl=estr_nucl+uprod/usum
21436           do j=1,3
21437            gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
21438           enddo
21439       endif
21440       enddo
21441 !C      print *,"I am about to leave ebond"
21442       return
21443       end subroutine ebond_nucl
21444
21445 !-----------------------------------------------------------------------------
21446       subroutine ebend_nucl(etheta_nucl)
21447       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
21448       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
21449       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
21450       logical :: lprn=.false., lprn1=.false.
21451 !el local variables
21452       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
21453       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
21454       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
21455 ! local variables for constrains
21456       real(kind=8) :: difi,thetiii
21457        integer itheta
21458       etheta_nucl=0.0D0
21459 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
21460       do i=ithet_nucl_start,ithet_nucl_end
21461       if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
21462       (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
21463       (itype(i,2).eq.ntyp1_molec(2))) cycle
21464       dethetai=0.0d0
21465       dephii=0.0d0
21466       dephii1=0.0d0
21467       theti2=0.5d0*theta(i)
21468       ityp2=ithetyp_nucl(itype(i-1,2))
21469       do k=1,nntheterm_nucl
21470         coskt(k)=dcos(k*theti2)
21471         sinkt(k)=dsin(k*theti2)
21472       enddo
21473       if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
21474 #ifdef OSF
21475         phii=phi(i)
21476         if (phii.ne.phii) phii=150.0
21477 #else
21478         phii=phi(i)
21479 #endif
21480         ityp1=ithetyp_nucl(itype(i-2,2))
21481         do k=1,nsingle_nucl
21482           cosph1(k)=dcos(k*phii)
21483           sinph1(k)=dsin(k*phii)
21484         enddo
21485       else
21486         phii=0.0d0
21487         ityp1=nthetyp_nucl+1
21488         do k=1,nsingle_nucl
21489           cosph1(k)=0.0d0
21490           sinph1(k)=0.0d0
21491         enddo
21492       endif
21493
21494       if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
21495 #ifdef OSF
21496         phii1=phi(i+1)
21497         if (phii1.ne.phii1) phii1=150.0
21498         phii1=pinorm(phii1)
21499 #else
21500         phii1=phi(i+1)
21501 #endif
21502         ityp3=ithetyp_nucl(itype(i,2))
21503         do k=1,nsingle_nucl
21504           cosph2(k)=dcos(k*phii1)
21505           sinph2(k)=dsin(k*phii1)
21506         enddo
21507       else
21508         phii1=0.0d0
21509         ityp3=nthetyp_nucl+1
21510         do k=1,nsingle_nucl
21511           cosph2(k)=0.0d0
21512           sinph2(k)=0.0d0
21513         enddo
21514       endif
21515       ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
21516       do k=1,ndouble_nucl
21517         do l=1,k-1
21518           ccl=cosph1(l)*cosph2(k-l)
21519           ssl=sinph1(l)*sinph2(k-l)
21520           scl=sinph1(l)*cosph2(k-l)
21521           csl=cosph1(l)*sinph2(k-l)
21522           cosph1ph2(l,k)=ccl-ssl
21523           cosph1ph2(k,l)=ccl+ssl
21524           sinph1ph2(l,k)=scl+csl
21525           sinph1ph2(k,l)=scl-csl
21526         enddo
21527       enddo
21528       if (lprn) then
21529       write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
21530        " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
21531       write (iout,*) "coskt and sinkt",nntheterm_nucl
21532       do k=1,nntheterm_nucl
21533         write (iout,*) k,coskt(k),sinkt(k)
21534       enddo
21535       endif
21536       do k=1,ntheterm_nucl
21537         ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
21538         dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
21539          *coskt(k)
21540         if (lprn)&
21541        write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
21542         " ethetai",ethetai
21543       enddo
21544       if (lprn) then
21545       write (iout,*) "cosph and sinph"
21546       do k=1,nsingle_nucl
21547         write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
21548       enddo
21549       write (iout,*) "cosph1ph2 and sinph2ph2"
21550       do k=2,ndouble_nucl
21551         do l=1,k-1
21552           write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
21553             sinph1ph2(l,k),sinph1ph2(k,l)
21554         enddo
21555       enddo
21556       write(iout,*) "ethetai",ethetai
21557       endif
21558       do m=1,ntheterm2_nucl
21559         do k=1,nsingle_nucl
21560           aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
21561             +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
21562             +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
21563             +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
21564           ethetai=ethetai+sinkt(m)*aux
21565           dethetai=dethetai+0.5d0*m*aux*coskt(m)
21566           dephii=dephii+k*sinkt(m)*(&
21567              ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
21568              bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
21569           dephii1=dephii1+k*sinkt(m)*(&
21570              eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
21571              ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
21572           if (lprn) &
21573          write (iout,*) "m",m," k",k," bbthet",&
21574             bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
21575             ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
21576             ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
21577             eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21578         enddo
21579       enddo
21580       if (lprn) &
21581       write(iout,*) "ethetai",ethetai
21582       do m=1,ntheterm3_nucl
21583         do k=2,ndouble_nucl
21584           do l=1,k-1
21585             aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21586              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
21587              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21588              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
21589             ethetai=ethetai+sinkt(m)*aux
21590             dethetai=dethetai+0.5d0*m*coskt(m)*aux
21591             dephii=dephii+l*sinkt(m)*(&
21592             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
21593              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21594              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21595              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21596             dephii1=dephii1+(k-l)*sinkt(m)*( &
21597             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21598              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21599              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
21600              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21601             if (lprn) then
21602             write (iout,*) "m",m," k",k," l",l," ffthet", &
21603              ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
21604              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
21605              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
21606              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21607             write (iout,*) cosph1ph2(l,k)*sinkt(m), &
21608              cosph1ph2(k,l)*sinkt(m),&
21609              sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
21610             endif
21611           enddo
21612         enddo
21613       enddo
21614 10      continue
21615       if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
21616       i,theta(i)*rad2deg,phii*rad2deg, &
21617       phii1*rad2deg,ethetai
21618       etheta_nucl=etheta_nucl+ethetai
21619 !        print *,i,"partial sum",etheta_nucl
21620       if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
21621       if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
21622       gloc(nphi+i-2,icg)=wang_nucl*dethetai
21623       enddo
21624       return
21625       end subroutine ebend_nucl
21626 !----------------------------------------------------
21627       subroutine etor_nucl(etors_nucl)
21628 !      implicit real*8 (a-h,o-z)
21629 !      include 'DIMENSIONS'
21630 !      include 'COMMON.VAR'
21631 !      include 'COMMON.GEO'
21632 !      include 'COMMON.LOCAL'
21633 !      include 'COMMON.TORSION'
21634 !      include 'COMMON.INTERACT'
21635 !      include 'COMMON.DERIV'
21636 !      include 'COMMON.CHAIN'
21637 !      include 'COMMON.NAMES'
21638 !      include 'COMMON.IOUNITS'
21639 !      include 'COMMON.FFIELD'
21640 !      include 'COMMON.TORCNSTR'
21641 !      include 'COMMON.CONTROL'
21642       real(kind=8) :: etors_nucl,edihcnstr
21643       logical :: lprn
21644 !el local variables
21645       integer :: i,j,iblock,itori,itori1
21646       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
21647                vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
21648 ! Set lprn=.true. for debugging
21649       lprn=.false.
21650 !     lprn=.true.
21651       etors_nucl=0.0D0
21652 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
21653       do i=iphi_nucl_start,iphi_nucl_end
21654       if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
21655            .or. itype(i-3,2).eq.ntyp1_molec(2) &
21656            .or. itype(i,2).eq.ntyp1_molec(2)) cycle
21657       etors_ii=0.0D0
21658       itori=itortyp_nucl(itype(i-2,2))
21659       itori1=itortyp_nucl(itype(i-1,2))
21660       phii=phi(i)
21661 !         print *,i,itori,itori1
21662       gloci=0.0D0
21663 !C Regular cosine and sine terms
21664       do j=1,nterm_nucl(itori,itori1)
21665         v1ij=v1_nucl(j,itori,itori1)
21666         v2ij=v2_nucl(j,itori,itori1)
21667         cosphi=dcos(j*phii)
21668         sinphi=dsin(j*phii)
21669         etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
21670         if (energy_dec) etors_ii=etors_ii+&
21671                  v1ij*cosphi+v2ij*sinphi
21672         gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
21673       enddo
21674 !C Lorentz terms
21675 !C                         v1
21676 !C  E = SUM ----------------------------------- - v1
21677 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
21678 !C
21679       cosphi=dcos(0.5d0*phii)
21680       sinphi=dsin(0.5d0*phii)
21681       do j=1,nlor_nucl(itori,itori1)
21682         vl1ij=vlor1_nucl(j,itori,itori1)
21683         vl2ij=vlor2_nucl(j,itori,itori1)
21684         vl3ij=vlor3_nucl(j,itori,itori1)
21685         pom=vl2ij*cosphi+vl3ij*sinphi
21686         pom1=1.0d0/(pom*pom+1.0d0)
21687         etors_nucl=etors_nucl+vl1ij*pom1
21688         if (energy_dec) etors_ii=etors_ii+ &
21689                  vl1ij*pom1
21690         pom=-pom*pom1*pom1
21691         gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
21692       enddo
21693 !C Subtract the constant term
21694       etors_nucl=etors_nucl-v0_nucl(itori,itori1)
21695         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
21696             'etor',i,etors_ii-v0_nucl(itori,itori1)
21697       if (lprn) &
21698        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
21699        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
21700        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
21701       gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
21702 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
21703       enddo
21704       return
21705       end subroutine etor_nucl
21706 !------------------------------------------------------------
21707       subroutine epp_nucl_sub(evdw1,ees)
21708 !C
21709 !C This subroutine calculates the average interaction energy and its gradient
21710 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
21711 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
21712 !C The potential depends both on the distance of peptide-group centers and on
21713 !C the orientation of the CA-CA virtual bonds.
21714 !C
21715       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
21716       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbbi,sslipi,ssgradlipi, &
21717                       sslipj,ssgradlipj,faclipij2
21718       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
21719              dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
21720              dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
21721       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21722                 dist_temp, dist_init,sss_grad,fac,evdw1ij
21723       integer xshift,yshift,zshift
21724       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
21725       real(kind=8) :: ees,eesij
21726 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21727       real(kind=8) scal_el /0.5d0/
21728       t_eelecij=0.0d0
21729       ees=0.0D0
21730       evdw1=0.0D0
21731       ind=0
21732 !c
21733 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
21734 !c
21735 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
21736       do i=iatel_s_nucl,iatel_e_nucl
21737       if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21738       dxi=dc(1,i)
21739       dyi=dc(2,i)
21740       dzi=dc(3,i)
21741       dx_normi=dc_norm(1,i)
21742       dy_normi=dc_norm(2,i)
21743       dz_normi=dc_norm(3,i)
21744       xmedi=c(1,i)+0.5d0*dxi
21745       ymedi=c(2,i)+0.5d0*dyi
21746       zmedi=c(3,i)+0.5d0*dzi
21747         call to_box(xmedi,ymedi,zmedi)
21748         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
21749
21750       do j=ielstart_nucl(i),ielend_nucl(i)
21751         if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
21752         ind=ind+1
21753         dxj=dc(1,j)
21754         dyj=dc(2,j)
21755         dzj=dc(3,j)
21756 !          xj=c(1,j)+0.5D0*dxj-xmedi
21757 !          yj=c(2,j)+0.5D0*dyj-ymedi
21758 !          zj=c(3,j)+0.5D0*dzj-zmedi
21759         xj=c(1,j)+0.5D0*dxj
21760         yj=c(2,j)+0.5D0*dyj
21761         zj=c(3,j)+0.5D0*dzj
21762      call to_box(xj,yj,zj)
21763      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
21764       faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
21765       xj=boxshift(xj-xmedi,boxxsize)
21766       yj=boxshift(yj-ymedi,boxysize)
21767       zj=boxshift(zj-zmedi,boxzsize)
21768         rij=xj*xj+yj*yj+zj*zj
21769 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
21770         fac=(r0pp**2/rij)**3
21771         ev1=epspp*fac*fac
21772         ev2=epspp*fac
21773         evdw1ij=ev1-2*ev2
21774         fac=(-ev1-evdw1ij)/rij
21775 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
21776         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
21777         evdw1=evdw1+evdw1ij
21778 !C
21779 !C Calculate contributions to the Cartesian gradient.
21780 !C
21781         ggg(1)=fac*xj
21782         ggg(2)=fac*yj
21783         ggg(3)=fac*zj
21784         do k=1,3
21785           gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
21786           gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
21787         enddo
21788 !c phoshate-phosphate electrostatic interactions
21789         rij=dsqrt(rij)
21790         fac=1.0d0/rij
21791         eesij=dexp(-BEES*rij)*fac
21792 !          write (2,*)"fac",fac," eesijpp",eesij
21793         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
21794         ees=ees+eesij
21795 !c          fac=-eesij*fac
21796         fac=-(fac+BEES)*eesij*fac
21797         ggg(1)=fac*xj
21798         ggg(2)=fac*yj
21799         ggg(3)=fac*zj
21800 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
21801 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
21802 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
21803         do k=1,3
21804           gelpp(k,i)=gelpp(k,i)-ggg(k)
21805           gelpp(k,j)=gelpp(k,j)+ggg(k)
21806         enddo
21807       enddo ! j
21808       enddo   ! i
21809 !c      ees=332.0d0*ees
21810       ees=AEES*ees
21811       do i=nnt,nct
21812 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21813       do k=1,3
21814         gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
21815 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
21816         gelpp(k,i)=AEES*gelpp(k,i)
21817       enddo
21818 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21819       enddo
21820 !c      write (2,*) "total EES",ees
21821       return
21822       end subroutine epp_nucl_sub
21823 !---------------------------------------------------------------------
21824       subroutine epsb(evdwpsb,eelpsb)
21825 !      use comm_locel
21826 !C
21827 !C This subroutine calculates the excluded-volume interaction energy between
21828 !C peptide-group centers and side chains and its gradient in virtual-bond and
21829 !C side-chain vectors.
21830 !C
21831       real(kind=8),dimension(3):: ggg
21832       integer :: i,iint,j,k,iteli,itypj,subchap
21833       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
21834                e1,e2,evdwij,rij,evdwpsb,eelpsb
21835       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21836                 dist_temp, dist_init
21837       integer xshift,yshift,zshift
21838
21839 !cd    print '(a)','Enter ESCP'
21840 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
21841       eelpsb=0.0d0
21842       evdwpsb=0.0d0
21843 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
21844       do i=iatscp_s_nucl,iatscp_e_nucl
21845       if (itype(i,2).eq.ntyp1_molec(2) &
21846        .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21847       xi=0.5D0*(c(1,i)+c(1,i+1))
21848       yi=0.5D0*(c(2,i)+c(2,i+1))
21849       zi=0.5D0*(c(3,i)+c(3,i+1))
21850         call to_box(xi,yi,zi)
21851
21852       do iint=1,nscp_gr_nucl(i)
21853
21854       do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
21855         itypj=itype(j,2)
21856         if (itypj.eq.ntyp1_molec(2)) cycle
21857 !C Uncomment following three lines for SC-p interactions
21858 !c         xj=c(1,nres+j)-xi
21859 !c         yj=c(2,nres+j)-yi
21860 !c         zj=c(3,nres+j)-zi
21861 !C Uncomment following three lines for Ca-p interactions
21862 !          xj=c(1,j)-xi
21863 !          yj=c(2,j)-yi
21864 !          zj=c(3,j)-zi
21865         xj=c(1,j)
21866         yj=c(2,j)
21867         zj=c(3,j)
21868         call to_box(xj,yj,zj)
21869       xj=boxshift(xj-xi,boxxsize)
21870       yj=boxshift(yj-yi,boxysize)
21871       zj=boxshift(zj-zi,boxzsize)
21872
21873       dist_init=xj**2+yj**2+zj**2
21874
21875         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21876         fac=rrij**expon2
21877         e1=fac*fac*aad_nucl(itypj)
21878         e2=fac*bad_nucl(itypj)
21879         if (iabs(j-i) .le. 2) then
21880           e1=scal14*e1
21881           e2=scal14*e2
21882         endif
21883         evdwij=e1+e2
21884         evdwpsb=evdwpsb+evdwij
21885         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
21886            'evdw2',i,j,evdwij,"tu4"
21887 !C
21888 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
21889 !C
21890         fac=-(evdwij+e1)*rrij
21891         ggg(1)=xj*fac
21892         ggg(2)=yj*fac
21893         ggg(3)=zj*fac
21894         do k=1,3
21895           gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
21896           gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
21897         enddo
21898       enddo
21899
21900       enddo ! iint
21901       enddo ! i
21902       do i=1,nct
21903       do j=1,3
21904         gvdwpsb(j,i)=expon*gvdwpsb(j,i)
21905         gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
21906       enddo
21907       enddo
21908       return
21909       end subroutine epsb
21910
21911 !------------------------------------------------------
21912       subroutine esb_gb(evdwsb,eelsb)
21913       use comm_locel
21914       use calc_data_nucl
21915       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
21916       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
21917       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
21918       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21919                 dist_temp, dist_init,aa,bb,faclip,sig0ij
21920       integer :: ii
21921       logical lprn
21922       evdw=0.0D0
21923       eelsb=0.0d0
21924       ecorr=0.0d0
21925       evdwsb=0.0D0
21926       lprn=.false.
21927       ind=0
21928 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
21929       do i=iatsc_s_nucl,iatsc_e_nucl
21930       num_conti=0
21931       num_conti2=0
21932       itypi=itype(i,2)
21933 !        PRINT *,"I=",i,itypi
21934       if (itypi.eq.ntyp1_molec(2)) cycle
21935       itypi1=itype(i+1,2)
21936       xi=c(1,nres+i)
21937       yi=c(2,nres+i)
21938       zi=c(3,nres+i)
21939       call to_box(xi,yi,zi)
21940       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
21941       dxi=dc_norm(1,nres+i)
21942       dyi=dc_norm(2,nres+i)
21943       dzi=dc_norm(3,nres+i)
21944       dsci_inv=vbld_inv(i+nres)
21945 !C
21946 !C Calculate SC interaction energy.
21947 !C
21948       do iint=1,nint_gr_nucl(i)
21949 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
21950         do j=istart_nucl(i,iint),iend_nucl(i,iint)
21951           ind=ind+1
21952 !            print *,"JESTEM"
21953           itypj=itype(j,2)
21954           if (itypj.eq.ntyp1_molec(2)) cycle
21955           dscj_inv=vbld_inv(j+nres)
21956           sig0ij=sigma_nucl(itypi,itypj)
21957           chi1=chi_nucl(itypi,itypj)
21958           chi2=chi_nucl(itypj,itypi)
21959           chi12=chi1*chi2
21960           chip1=chip_nucl(itypi,itypj)
21961           chip2=chip_nucl(itypj,itypi)
21962           chip12=chip1*chip2
21963 !            xj=c(1,nres+j)-xi
21964 !            yj=c(2,nres+j)-yi
21965 !            zj=c(3,nres+j)-zi
21966          xj=c(1,nres+j)
21967          yj=c(2,nres+j)
21968          zj=c(3,nres+j)
21969      call to_box(xj,yj,zj)
21970 !     call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
21971 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
21972 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
21973 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
21974 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
21975       xj=boxshift(xj-xi,boxxsize)
21976       yj=boxshift(yj-yi,boxysize)
21977       zj=boxshift(zj-zi,boxzsize)
21978
21979           dxj=dc_norm(1,nres+j)
21980           dyj=dc_norm(2,nres+j)
21981           dzj=dc_norm(3,nres+j)
21982           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21983           rij=dsqrt(rrij)
21984 !C Calculate angle-dependent terms of energy and contributions to their
21985 !C derivatives.
21986           erij(1)=xj*rij
21987           erij(2)=yj*rij
21988           erij(3)=zj*rij
21989           om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
21990           om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
21991           om12=dxi*dxj+dyi*dyj+dzi*dzj
21992           call sc_angular_nucl
21993           sigsq=1.0D0/sigsq
21994           sig=sig0ij*dsqrt(sigsq)
21995           rij_shift=1.0D0/rij-sig+sig0ij
21996 !            print *,rij_shift,"rij_shift"
21997 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
21998 !c     &       " rij_shift",rij_shift
21999           if (rij_shift.le.0.0D0) then
22000             evdw=1.0D20
22001             return
22002           endif
22003           sigder=-sig*sigsq
22004 !c---------------------------------------------------------------
22005           rij_shift=1.0D0/rij_shift
22006           fac=rij_shift**expon
22007           e1=fac*fac*aa_nucl(itypi,itypj)
22008           e2=fac*bb_nucl(itypi,itypj)
22009           evdwij=eps1*eps2rt*(e1+e2)
22010 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
22011 !c     &       " e1",e1," e2",e2," evdwij",evdwij
22012           eps2der=evdwij
22013           evdwij=evdwij*eps2rt
22014           evdwsb=evdwsb+evdwij
22015           if (lprn) then
22016           sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
22017           epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
22018           write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
22019            restyp(itypi,2),i,restyp(itypj,2),j, &
22020            epsi,sigm,chi1,chi2,chip1,chip2, &
22021            eps1,eps2rt**2,sig,sig0ij, &
22022            om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
22023           evdwij
22024           write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
22025           endif
22026
22027           if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
22028                        'evdw',i,j,evdwij,"tu3"
22029
22030
22031 !C Calculate gradient components.
22032           e1=e1*eps1*eps2rt**2
22033           fac=-expon*(e1+evdwij)*rij_shift
22034           sigder=fac*sigder
22035           fac=rij*fac
22036 !c            fac=0.0d0
22037 !C Calculate the radial part of the gradient
22038           gg(1)=xj*fac
22039           gg(2)=yj*fac
22040           gg(3)=zj*fac
22041 !C Calculate angular part of the gradient.
22042           call sc_grad_nucl
22043           call eelsbij(eelij,num_conti2)
22044           if (energy_dec .and. &
22045          (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
22046         write (istat,'(e14.5)') evdwij
22047           eelsb=eelsb+eelij
22048         enddo      ! j
22049       enddo        ! iint
22050       num_cont_hb(i)=num_conti2
22051       enddo          ! i
22052 !c      write (iout,*) "Number of loop steps in EGB:",ind
22053 !cccc      energy_dec=.false.
22054       return
22055       end subroutine esb_gb
22056 !-------------------------------------------------------------------------------
22057       subroutine eelsbij(eesij,num_conti2)
22058       use comm_locel
22059       use calc_data_nucl
22060       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
22061       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
22062       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22063                 dist_temp, dist_init,rlocshield,fracinbuf
22064       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
22065
22066 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
22067       real(kind=8) scal_el /0.5d0/
22068       integer :: iteli,itelj,kkk,kkll,m,isubchap
22069       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
22070       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
22071       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
22072               r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
22073               el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
22074               ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
22075               a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
22076               ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
22077               ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
22078               ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
22079       ind=ind+1
22080       itypi=itype(i,2)
22081       itypj=itype(j,2)
22082 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
22083       ael6i=ael6_nucl(itypi,itypj)
22084       ael3i=ael3_nucl(itypi,itypj)
22085       ael63i=ael63_nucl(itypi,itypj)
22086       ael32i=ael32_nucl(itypi,itypj)
22087 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
22088 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
22089       dxj=dc(1,j+nres)
22090       dyj=dc(2,j+nres)
22091       dzj=dc(3,j+nres)
22092       dx_normi=dc_norm(1,i+nres)
22093       dy_normi=dc_norm(2,i+nres)
22094       dz_normi=dc_norm(3,i+nres)
22095       dx_normj=dc_norm(1,j+nres)
22096       dy_normj=dc_norm(2,j+nres)
22097       dz_normj=dc_norm(3,j+nres)
22098 !c      xj=c(1,j)+0.5D0*dxj-xmedi
22099 !c      yj=c(2,j)+0.5D0*dyj-ymedi
22100 !c      zj=c(3,j)+0.5D0*dzj-zmedi
22101       if (ipot_nucl.ne.2) then
22102       cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
22103       cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
22104       cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
22105       else
22106       cosa=om12
22107       cosb=om1
22108       cosg=om2
22109       endif
22110       r3ij=rij*rrij
22111       r6ij=r3ij*r3ij
22112       fac=cosa-3.0D0*cosb*cosg
22113       facfac=fac*fac
22114       fac1=3.0d0*(cosb*cosb+cosg*cosg)
22115       fac3=ael6i*r6ij
22116       fac4=ael3i*r3ij
22117       fac5=ael63i*r6ij
22118       fac6=ael32i*r6ij
22119 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
22120 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
22121       el1=fac3*(4.0D0+facfac-fac1)
22122       el2=fac4*fac
22123       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
22124       el4=fac6*facfac
22125       eesij=el1+el2+el3+el4
22126 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
22127       ees0ij=4.0D0+facfac-fac1
22128
22129       if (energy_dec) then
22130         if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
22131         write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
22132          sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
22133          restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
22134          (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
22135         write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
22136       endif
22137
22138 !C
22139 !C Calculate contributions to the Cartesian gradient.
22140 !C
22141       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
22142       fac1=fac
22143 !c      erij(1)=xj*rmij
22144 !c      erij(2)=yj*rmij
22145 !c      erij(3)=zj*rmij
22146 !*
22147 !* Radial derivatives. First process both termini of the fragment (i,j)
22148 !*
22149       ggg(1)=facel*xj
22150       ggg(2)=facel*yj
22151       ggg(3)=facel*zj
22152       do k=1,3
22153       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
22154       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
22155       gelsbx(k,j)=gelsbx(k,j)+ggg(k)
22156       gelsbx(k,i)=gelsbx(k,i)-ggg(k)
22157       enddo
22158 !*
22159 !* Angular part
22160 !*
22161       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
22162       fac4=-3.0D0*fac4
22163       fac3=-6.0D0*fac3
22164       fac5= 6.0d0*fac5
22165       fac6=-6.0d0*fac6
22166       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
22167        fac6*fac1*cosg
22168       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
22169        fac6*fac1*cosb
22170       do k=1,3
22171       dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
22172       dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
22173       enddo
22174       do k=1,3
22175       ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
22176       enddo
22177       do k=1,3
22178       gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
22179            +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
22180            + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
22181       gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
22182            +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
22183            + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
22184       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
22185       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
22186       enddo
22187 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
22188        IF ( j.gt.i+1 .and.&
22189         num_conti.le.maxcont) THEN
22190 !C
22191 !C Calculate the contact function. The ith column of the array JCONT will
22192 !C contain the numbers of atoms that make contacts with the atom I (of numbers
22193 !C greater than I). The arrays FACONT and GACONT will contain the values of
22194 !C the contact function and its derivative.
22195       r0ij=2.20D0*sigma_nucl(itypi,itypj)
22196 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
22197       call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
22198 !c        write (2,*) "fcont",fcont
22199       if (fcont.gt.0.0D0) then
22200         num_conti=num_conti+1
22201         num_conti2=num_conti2+1
22202
22203         if (num_conti.gt.maxconts) then
22204           write (iout,*) 'WARNING - max. # of contacts exceeded;',&
22205                     ' will skip next contacts for this conf.',maxconts
22206         else
22207           jcont_hb(num_conti,i)=j
22208 !c            write (iout,*) "num_conti",num_conti,
22209 !c     &        " jcont_hb",jcont_hb(num_conti,i)
22210 !C Calculate contact energies
22211           cosa4=4.0D0*cosa
22212           wij=cosa-3.0D0*cosb*cosg
22213           cosbg1=cosb+cosg
22214           cosbg2=cosb-cosg
22215           fac3=dsqrt(-ael6i)*r3ij
22216 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
22217           ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
22218           if (ees0tmp.gt.0) then
22219             ees0pij=dsqrt(ees0tmp)
22220           else
22221             ees0pij=0
22222           endif
22223           ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
22224           if (ees0tmp.gt.0) then
22225             ees0mij=dsqrt(ees0tmp)
22226           else
22227             ees0mij=0
22228           endif
22229           ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
22230           ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
22231 !c            write (iout,*) "i",i," j",j,
22232 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
22233           ees0pij1=fac3/ees0pij
22234           ees0mij1=fac3/ees0mij
22235           fac3p=-3.0D0*fac3*rrij
22236           ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
22237           ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
22238           ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
22239           ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
22240           ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
22241           ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
22242           ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
22243           ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
22244           ecosap=ecosa1+ecosa2
22245           ecosbp=ecosb1+ecosb2
22246           ecosgp=ecosg1+ecosg2
22247           ecosam=ecosa1-ecosa2
22248           ecosbm=ecosb1-ecosb2
22249           ecosgm=ecosg1-ecosg2
22250 !C End diagnostics
22251           facont_hb(num_conti,i)=fcont
22252           fprimcont=fprimcont/rij
22253           do k=1,3
22254             gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
22255             gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
22256           enddo
22257           gggp(1)=gggp(1)+ees0pijp*xj
22258           gggp(2)=gggp(2)+ees0pijp*yj
22259           gggp(3)=gggp(3)+ees0pijp*zj
22260           gggm(1)=gggm(1)+ees0mijp*xj
22261           gggm(2)=gggm(2)+ees0mijp*yj
22262           gggm(3)=gggm(3)+ees0mijp*zj
22263 !C Derivatives due to the contact function
22264           gacont_hbr(1,num_conti,i)=fprimcont*xj
22265           gacont_hbr(2,num_conti,i)=fprimcont*yj
22266           gacont_hbr(3,num_conti,i)=fprimcont*zj
22267           do k=1,3
22268 !c
22269 !c Gradient of the correlation terms
22270 !c
22271             gacontp_hb1(k,num_conti,i)= &
22272            (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
22273           + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
22274             gacontp_hb2(k,num_conti,i)= &
22275            (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
22276           + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
22277             gacontp_hb3(k,num_conti,i)=gggp(k)
22278             gacontm_hb1(k,num_conti,i)= &
22279            (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
22280           + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
22281             gacontm_hb2(k,num_conti,i)= &
22282            (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
22283           + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
22284             gacontm_hb3(k,num_conti,i)=gggm(k)
22285           enddo
22286         endif
22287       endif
22288       ENDIF
22289       return
22290       end subroutine eelsbij
22291 !------------------------------------------------------------------
22292       subroutine sc_grad_nucl
22293       use comm_locel
22294       use calc_data_nucl
22295       real(kind=8),dimension(3) :: dcosom1,dcosom2
22296       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
22297       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
22298       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
22299       do k=1,3
22300       dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
22301       dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
22302       enddo
22303       do k=1,3
22304       gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
22305       enddo
22306       do k=1,3
22307       gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
22308              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
22309              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22310       gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
22311              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22312              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22313       enddo
22314 !C
22315 !C Calculate the components of the gradient in DC and X
22316 !C
22317       do l=1,3
22318       gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
22319       gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
22320       enddo
22321       return
22322       end subroutine sc_grad_nucl
22323 !-----------------------------------------------------------------------
22324       subroutine esb(esbloc)
22325 !C Calculate the local energy of a side chain and its derivatives in the
22326 !C corresponding virtual-bond valence angles THETA and the spherical angles
22327 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
22328 !C added by Urszula Kozlowska. 07/11/2007
22329 !C
22330       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
22331       real(kind=8),dimension(9):: x
22332      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
22333       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
22334       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
22335       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
22336        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
22337        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
22338        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
22339        integer::it,nlobit,i,j,k
22340 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
22341       delta=0.02d0*pi
22342       esbloc=0.0D0
22343       do i=loc_start_nucl,loc_end_nucl
22344       if (itype(i,2).eq.ntyp1_molec(2)) cycle
22345       costtab(i+1) =dcos(theta(i+1))
22346       sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
22347       cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
22348       sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
22349       cosfac2=0.5d0/(1.0d0+costtab(i+1))
22350       cosfac=dsqrt(cosfac2)
22351       sinfac2=0.5d0/(1.0d0-costtab(i+1))
22352       sinfac=dsqrt(sinfac2)
22353       it=itype(i,2)
22354       if (it.eq.10) goto 1
22355
22356 !c
22357 !C  Compute the axes of tghe local cartesian coordinates system; store in
22358 !c   x_prime, y_prime and z_prime
22359 !c
22360       do j=1,3
22361         x_prime(j) = 0.00
22362         y_prime(j) = 0.00
22363         z_prime(j) = 0.00
22364       enddo
22365 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
22366 !C     &   dc_norm(3,i+nres)
22367       do j = 1,3
22368         x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
22369         y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
22370       enddo
22371       do j = 1,3
22372         z_prime(j) = -uz(j,i-1)
22373 !           z_prime(j)=0.0
22374       enddo
22375
22376       xx=0.0d0
22377       yy=0.0d0
22378       zz=0.0d0
22379       do j = 1,3
22380         xx = xx + x_prime(j)*dc_norm(j,i+nres)
22381         yy = yy + y_prime(j)*dc_norm(j,i+nres)
22382         zz = zz + z_prime(j)*dc_norm(j,i+nres)
22383       enddo
22384
22385       xxtab(i)=xx
22386       yytab(i)=yy
22387       zztab(i)=zz
22388        it=itype(i,2)
22389       do j = 1,9
22390         x(j) = sc_parmin_nucl(j,it)
22391       enddo
22392 #ifdef CHECK_COORD
22393 !Cc diagnostics - remove later
22394       xx1 = dcos(alph(2))
22395       yy1 = dsin(alph(2))*dcos(omeg(2))
22396       zz1 = -dsin(alph(2))*dsin(omeg(2))
22397       write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
22398        alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
22399        xx1,yy1,zz1
22400 !C,"  --- ", xx_w,yy_w,zz_w
22401 !c end diagnostics
22402 #endif
22403       sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22404       esbloc = esbloc + sumene
22405       sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
22406 !        print *,"enecomp",sumene,sumene2
22407 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
22408 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
22409 #ifdef DEBUG
22410       write (2,*) "x",(x(k),k=1,9)
22411 !C
22412 !C This section to check the numerical derivatives of the energy of ith side
22413 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
22414 !C #define DEBUG in the code to turn it on.
22415 !C
22416       write (2,*) "sumene               =",sumene
22417       aincr=1.0d-7
22418       xxsave=xx
22419       xx=xx+aincr
22420       write (2,*) xx,yy,zz
22421       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22422       de_dxx_num=(sumenep-sumene)/aincr
22423       xx=xxsave
22424       write (2,*) "xx+ sumene from enesc=",sumenep,sumene
22425       yysave=yy
22426       yy=yy+aincr
22427       write (2,*) xx,yy,zz
22428       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22429       de_dyy_num=(sumenep-sumene)/aincr
22430       yy=yysave
22431       write (2,*) "yy+ sumene from enesc=",sumenep,sumene
22432       zzsave=zz
22433       zz=zz+aincr
22434       write (2,*) xx,yy,zz
22435       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22436       de_dzz_num=(sumenep-sumene)/aincr
22437       zz=zzsave
22438       write (2,*) "zz+ sumene from enesc=",sumenep,sumene
22439       costsave=cost2tab(i+1)
22440       sintsave=sint2tab(i+1)
22441       cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
22442       sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
22443       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22444       de_dt_num=(sumenep-sumene)/aincr
22445       write (2,*) " t+ sumene from enesc=",sumenep,sumene
22446       cost2tab(i+1)=costsave
22447       sint2tab(i+1)=sintsave
22448 !C End of diagnostics section.
22449 #endif
22450 !C
22451 !C Compute the gradient of esc
22452 !C
22453       de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
22454       de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
22455       de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
22456       de_dtt=0.0d0
22457 #ifdef DEBUG
22458       write (2,*) "x",(x(k),k=1,9)
22459       write (2,*) "xx",xx," yy",yy," zz",zz
22460       write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
22461         " de_zz   ",de_zz," de_tt   ",de_tt
22462       write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
22463         " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
22464 #endif
22465 !C
22466        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
22467        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
22468        cosfac2xx=cosfac2*xx
22469        sinfac2yy=sinfac2*yy
22470        do k = 1,3
22471        dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
22472          vbld_inv(i+1)
22473        dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
22474          vbld_inv(i)
22475        pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
22476        pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
22477 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
22478 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
22479 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
22480 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
22481        dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
22482        dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
22483        dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
22484        dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
22485        dZZ_Ci1(k)=0.0d0
22486        dZZ_Ci(k)=0.0d0
22487        do j=1,3
22488          dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
22489          dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
22490        enddo
22491
22492        dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
22493        dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
22494        dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
22495 !c
22496        dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
22497        dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
22498        enddo
22499
22500        do k=1,3
22501        dXX_Ctab(k,i)=dXX_Ci(k)
22502        dXX_C1tab(k,i)=dXX_Ci1(k)
22503        dYY_Ctab(k,i)=dYY_Ci(k)
22504        dYY_C1tab(k,i)=dYY_Ci1(k)
22505        dZZ_Ctab(k,i)=dZZ_Ci(k)
22506        dZZ_C1tab(k,i)=dZZ_Ci1(k)
22507        dXX_XYZtab(k,i)=dXX_XYZ(k)
22508        dYY_XYZtab(k,i)=dYY_XYZ(k)
22509        dZZ_XYZtab(k,i)=dZZ_XYZ(k)
22510        enddo
22511        do k = 1,3
22512 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
22513 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
22514 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
22515 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
22516 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
22517 !c     &    dt_dci(k)
22518 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
22519 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
22520        gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
22521        +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
22522        gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
22523        +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
22524        gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
22525        +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
22526 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
22527        enddo
22528 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
22529 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
22530
22531 !C to check gradient call subroutine check_grad
22532
22533     1 continue
22534       enddo
22535       return
22536       end subroutine esb
22537 !=-------------------------------------------------------
22538       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
22539 !      implicit none
22540       real(kind=8),dimension(9):: x(9)
22541        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
22542       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
22543       integer i
22544 !c      write (2,*) "enesc"
22545 !c      write (2,*) "x",(x(i),i=1,9)
22546 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
22547       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
22548       + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
22549       + x(9)*yy*zz
22550       enesc_nucl=sumene
22551       return
22552       end function enesc_nucl
22553 !-----------------------------------------------------------------------------
22554       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
22555 #ifdef MPI
22556       include 'mpif.h'
22557       integer,parameter :: max_cont=2000
22558       integer,parameter:: max_dim=2*(8*3+6)
22559       integer, parameter :: msglen1=max_cont*max_dim
22560       integer,parameter :: msglen2=2*msglen1
22561       integer source,CorrelType,CorrelID,Error
22562       real(kind=8) :: buffer(max_cont,max_dim)
22563       integer status(MPI_STATUS_SIZE)
22564       integer :: ierror,nbytes
22565 #endif
22566       real(kind=8),dimension(3):: gx(3),gx1(3)
22567       real(kind=8) :: time00
22568       logical lprn,ldone
22569       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
22570       real(kind=8) ecorr,ecorr3
22571       integer :: n_corr,n_corr1,mm,msglen
22572 !C Set lprn=.true. for debugging
22573       lprn=.false.
22574       n_corr=0
22575       n_corr1=0
22576 #ifdef MPI
22577       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
22578
22579       if (nfgtasks.le.1) goto 30
22580       if (lprn) then
22581       write (iout,'(a)') 'Contact function values:'
22582       do i=nnt,nct-1
22583         write (iout,'(2i3,50(1x,i2,f5.2))')  &
22584        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22585        j=1,num_cont_hb(i))
22586       enddo
22587       endif
22588 !C Caution! Following code assumes that electrostatic interactions concerning
22589 !C a given atom are split among at most two processors!
22590       CorrelType=477
22591       CorrelID=fg_rank+1
22592       ldone=.false.
22593       do i=1,max_cont
22594       do j=1,max_dim
22595         buffer(i,j)=0.0D0
22596       enddo
22597       enddo
22598       mm=mod(fg_rank,2)
22599 !c      write (*,*) 'MyRank',MyRank,' mm',mm
22600       if (mm) 20,20,10
22601    10 continue
22602 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
22603       if (fg_rank.gt.0) then
22604 !C Send correlation contributions to the preceding processor
22605       msglen=msglen1
22606       nn=num_cont_hb(iatel_s_nucl)
22607       call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
22608 !c        write (*,*) 'The BUFFER array:'
22609 !c        do i=1,nn
22610 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
22611 !c        enddo
22612       if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
22613         msglen=msglen2
22614         call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
22615 !C Clear the contacts of the atom passed to the neighboring processor
22616       nn=num_cont_hb(iatel_s_nucl+1)
22617 !c        do i=1,nn
22618 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
22619 !c        enddo
22620           num_cont_hb(iatel_s_nucl)=0
22621       endif
22622 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
22623 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
22624 !cd   & ' msglen=',msglen
22625 !c        write (*,*) 'Processor ',fg_rank,MyRank,
22626 !c     & ' is sending correlation contribution to processor',fg_rank-1,
22627 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22628       time00=MPI_Wtime()
22629       call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
22630        CorrelType,FG_COMM,IERROR)
22631       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22632 !cd      write (iout,*) 'Processor ',fg_rank,
22633 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
22634 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
22635 !c        write (*,*) 'Processor ',fg_rank,
22636 !c     & ' has sent correlation contribution to processor',fg_rank-1,
22637 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
22638 !c        msglen=msglen1
22639       endif ! (fg_rank.gt.0)
22640       if (ldone) goto 30
22641       ldone=.true.
22642    20 continue
22643 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
22644       if (fg_rank.lt.nfgtasks-1) then
22645 !C Receive correlation contributions from the next processor
22646       msglen=msglen1
22647       if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
22648 !cd      write (iout,*) 'Processor',fg_rank,
22649 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
22650 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
22651 !c        write (*,*) 'Processor',fg_rank,
22652 !c     &' is receiving correlation contribution from processor',fg_rank+1,
22653 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22654       time00=MPI_Wtime()
22655       nbytes=-1
22656       do while (nbytes.le.0)
22657         call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22658         call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
22659       enddo
22660 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
22661       call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
22662        fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22663       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22664 !c        write (*,*) 'Processor',fg_rank,
22665 !c     &' has received correlation contribution from processor',fg_rank+1,
22666 !c     & ' msglen=',msglen,' nbytes=',nbytes
22667 !c        write (*,*) 'The received BUFFER array:'
22668 !c        do i=1,max_cont
22669 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
22670 !c        enddo
22671       if (msglen.eq.msglen1) then
22672         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
22673       else if (msglen.eq.msglen2)  then
22674         call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
22675         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
22676       else
22677         write (iout,*) &
22678       'ERROR!!!! message length changed while processing correlations.'
22679         write (*,*) &
22680       'ERROR!!!! message length changed while processing correlations.'
22681         call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
22682       endif ! msglen.eq.msglen1
22683       endif ! fg_rank.lt.nfgtasks-1
22684       if (ldone) goto 30
22685       ldone=.true.
22686       goto 10
22687    30 continue
22688 #endif
22689       if (lprn) then
22690       write (iout,'(a)') 'Contact function values:'
22691       do i=nnt_molec(2),nct_molec(2)-1
22692         write (iout,'(2i3,50(1x,i2,f5.2))') &
22693        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22694        j=1,num_cont_hb(i))
22695       enddo
22696       endif
22697       ecorr=0.0D0
22698       ecorr3=0.0d0
22699 !C Remove the loop below after debugging !!!
22700 !      do i=nnt_molec(2),nct_molec(2)
22701 !        do j=1,3
22702 !          gradcorr_nucl(j,i)=0.0D0
22703 !          gradxorr_nucl(j,i)=0.0D0
22704 !          gradcorr3_nucl(j,i)=0.0D0
22705 !          gradxorr3_nucl(j,i)=0.0D0
22706 !        enddo
22707 !      enddo
22708 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
22709 !C Calculate the local-electrostatic correlation terms
22710       do i=iatsc_s_nucl,iatsc_e_nucl
22711       i1=i+1
22712       num_conti=num_cont_hb(i)
22713       num_conti1=num_cont_hb(i+1)
22714 !        print *,i,num_conti,num_conti1
22715       do jj=1,num_conti
22716         j=jcont_hb(jj,i)
22717         do kk=1,num_conti1
22718           j1=jcont_hb(kk,i1)
22719 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
22720 !c     &         ' jj=',jj,' kk=',kk
22721           if (j1.eq.j+1 .or. j1.eq.j-1) then
22722 !C
22723 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
22724 !C The system gains extra energy.
22725 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
22726 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22727 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
22728 !C
22729             ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22730             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
22731              'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22732             n_corr=n_corr+1
22733           else if (j1.eq.j) then
22734 !C
22735 !C Contacts I-J and I-(J+1) occur simultaneously.
22736 !C The system loses extra energy.
22737 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
22738 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22739 !C Need to implement full formulas 32 from Liwo et al., 1998.
22740 !C
22741 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22742 !c     &         ' jj=',jj,' kk=',kk
22743             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
22744           endif
22745         enddo ! kk
22746         do kk=1,num_conti
22747           j1=jcont_hb(kk,i)
22748 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22749 !c     &         ' jj=',jj,' kk=',kk
22750           if (j1.eq.j+1) then
22751 !C Contacts I-J and (I+1)-J occur simultaneously.
22752 !C The system loses extra energy.
22753             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
22754           endif ! j1==j+1
22755         enddo ! kk
22756       enddo ! jj
22757       enddo ! i
22758       return
22759       end subroutine multibody_hb_nucl
22760 !-----------------------------------------------------------
22761       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22762 !      implicit real*8 (a-h,o-z)
22763 !      include 'DIMENSIONS'
22764 !      include 'COMMON.IOUNITS'
22765 !      include 'COMMON.DERIV'
22766 !      include 'COMMON.INTERACT'
22767 !      include 'COMMON.CONTACTS'
22768       real(kind=8),dimension(3) :: gx,gx1
22769       logical :: lprn
22770 !el local variables
22771       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22772       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22773                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22774                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22775                rlocshield
22776
22777       lprn=.false.
22778       eij=facont_hb(jj,i)
22779       ekl=facont_hb(kk,k)
22780       ees0pij=ees0p(jj,i)
22781       ees0pkl=ees0p(kk,k)
22782       ees0mij=ees0m(jj,i)
22783       ees0mkl=ees0m(kk,k)
22784       ekont=eij*ekl
22785       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22786 !      print *,"ehbcorr_nucl",ekont,ees
22787 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22788 !C Following 4 lines for diagnostics.
22789 !cd    ees0pkl=0.0D0
22790 !cd    ees0pij=1.0D0
22791 !cd    ees0mkl=0.0D0
22792 !cd    ees0mij=1.0D0
22793 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22794 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22795 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22796 !C Calculate the multi-body contribution to energy.
22797 !      ecorr_nucl=ecorr_nucl+ekont*ees
22798 !C Calculate multi-body contributions to the gradient.
22799       coeffpees0pij=coeffp*ees0pij
22800       coeffmees0mij=coeffm*ees0mij
22801       coeffpees0pkl=coeffp*ees0pkl
22802       coeffmees0mkl=coeffm*ees0mkl
22803       do ll=1,3
22804       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
22805        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22806        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22807       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
22808       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
22809       coeffmees0mkl*gacontm_hb2(ll,jj,i))
22810       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
22811       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
22812       coeffmees0mij*gacontm_hb1(ll,kk,k))
22813       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
22814       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22815       coeffmees0mij*gacontm_hb2(ll,kk,k))
22816       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22817         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22818         coeffmees0mkl*gacontm_hb3(ll,jj,i))
22819       gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
22820       gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
22821       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22822         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22823         coeffmees0mij*gacontm_hb3(ll,kk,k))
22824       gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
22825       gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
22826       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
22827       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
22828       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
22829       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
22830       enddo
22831       ehbcorr_nucl=ekont*ees
22832       return
22833       end function ehbcorr_nucl
22834 !-------------------------------------------------------------------------
22835
22836      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22837 !      implicit real*8 (a-h,o-z)
22838 !      include 'DIMENSIONS'
22839 !      include 'COMMON.IOUNITS'
22840 !      include 'COMMON.DERIV'
22841 !      include 'COMMON.INTERACT'
22842 !      include 'COMMON.CONTACTS'
22843       real(kind=8),dimension(3) :: gx,gx1
22844       logical :: lprn
22845 !el local variables
22846       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22847       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22848                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22849                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22850                rlocshield
22851
22852       lprn=.false.
22853       eij=facont_hb(jj,i)
22854       ekl=facont_hb(kk,k)
22855       ees0pij=ees0p(jj,i)
22856       ees0pkl=ees0p(kk,k)
22857       ees0mij=ees0m(jj,i)
22858       ees0mkl=ees0m(kk,k)
22859       ekont=eij*ekl
22860       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22861 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22862 !C Following 4 lines for diagnostics.
22863 !cd    ees0pkl=0.0D0
22864 !cd    ees0pij=1.0D0
22865 !cd    ees0mkl=0.0D0
22866 !cd    ees0mij=1.0D0
22867 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22868 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22869 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22870 !C Calculate the multi-body contribution to energy.
22871 !      ecorr=ecorr+ekont*ees
22872 !C Calculate multi-body contributions to the gradient.
22873       coeffpees0pij=coeffp*ees0pij
22874       coeffmees0mij=coeffm*ees0mij
22875       coeffpees0pkl=coeffp*ees0pkl
22876       coeffmees0mkl=coeffm*ees0mkl
22877       do ll=1,3
22878       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
22879        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22880        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22881       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
22882       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
22883       coeffmees0mkl*gacontm_hb2(ll,jj,i))
22884       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
22885       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
22886       coeffmees0mij*gacontm_hb1(ll,kk,k))
22887       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
22888       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22889       coeffmees0mij*gacontm_hb2(ll,kk,k))
22890       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22891         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22892         coeffmees0mkl*gacontm_hb3(ll,jj,i))
22893       gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
22894       gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
22895       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22896         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22897         coeffmees0mij*gacontm_hb3(ll,kk,k))
22898       gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
22899       gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
22900       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
22901       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
22902       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
22903       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
22904       enddo
22905       ehbcorr3_nucl=ekont*ees
22906       return
22907       end function ehbcorr3_nucl
22908 #ifdef MPI
22909       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
22910       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22911       real(kind=8):: buffer(dimen1,dimen2)
22912       num_kont=num_cont_hb(atom)
22913       do i=1,num_kont
22914       do k=1,8
22915         do j=1,3
22916           buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
22917         enddo ! j
22918       enddo ! k
22919       buffer(i,indx+25)=facont_hb(i,atom)
22920       buffer(i,indx+26)=ees0p(i,atom)
22921       buffer(i,indx+27)=ees0m(i,atom)
22922       buffer(i,indx+28)=d_cont(i,atom)
22923       buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
22924       enddo ! i
22925       buffer(1,indx+30)=dfloat(num_kont)
22926       return
22927       end subroutine pack_buffer
22928 !c------------------------------------------------------------------------------
22929       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
22930       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22931       real(kind=8):: buffer(dimen1,dimen2)
22932 !      double precision zapas
22933 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
22934 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
22935 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
22936 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
22937       num_kont=buffer(1,indx+30)
22938       num_kont_old=num_cont_hb(atom)
22939       num_cont_hb(atom)=num_kont+num_kont_old
22940       do i=1,num_kont
22941       ii=i+num_kont_old
22942       do k=1,8
22943         do j=1,3
22944           zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
22945         enddo ! j
22946       enddo ! k
22947       facont_hb(ii,atom)=buffer(i,indx+25)
22948       ees0p(ii,atom)=buffer(i,indx+26)
22949       ees0m(ii,atom)=buffer(i,indx+27)
22950       d_cont(i,atom)=buffer(i,indx+28)
22951       jcont_hb(ii,atom)=buffer(i,indx+29)
22952       enddo ! i
22953       return
22954       end subroutine unpack_buffer
22955 !c------------------------------------------------------------------------------
22956 #endif
22957       subroutine ecatcat(ecationcation)
22958       integer :: i,j,itmp,xshift,yshift,zshift,subchap,k,itypi,itypj
22959       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22960       r7,r4,ecationcation,k0,rcal,aa,bb,sslipi,ssgradlipi,sslipj,ssgradlipj
22961       real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22962       dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
22963       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22964       gg,r
22965
22966       ecationcation=0.0d0
22967       if (nres_molec(5).eq.0) return
22968       rcat0=3.472
22969       epscalc=0.05
22970       r06 = rcat0**6
22971       r012 = r06**2
22972 !        k0 = 332.0*(2.0*2.0)/80.0
22973       itmp=0
22974
22975       do i=1,4
22976       itmp=itmp+nres_molec(i)
22977       enddo
22978 !        write(iout,*) "itmp",itmp
22979       do i=itmp+1,itmp+nres_molec(5)-1
22980
22981       xi=c(1,i)
22982       yi=c(2,i)
22983       zi=c(3,i)
22984 !        write (iout,*) i,"TUTUT",c(1,i)
22985         itypi=itype(i,5)
22986       call to_box(xi,yi,zi)
22987       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
22988         do j=i+1,itmp+nres_molec(5)
22989         itypj=itype(j,5)
22990 !          print *,i,j,itypi,itypj
22991         k0 = 332.0*(ichargecat(itypi)*ichargecat(itypj))/80.0
22992 !           print *,i,j,'catcat'
22993          xj=c(1,j)
22994          yj=c(2,j)
22995          zj=c(3,j)
22996       call to_box(xj,yj,zj)
22997 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
22998 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22999 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23000 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23001 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23002       xj=boxshift(xj-xi,boxxsize)
23003       yj=boxshift(yj-yi,boxysize)
23004       zj=boxshift(zj-zi,boxzsize)
23005        rcal =xj**2+yj**2+zj**2
23006       ract=sqrt(rcal)
23007 !        rcat0=3.472
23008 !        epscalc=0.05
23009 !        r06 = rcat0**6
23010 !        r012 = r06**2
23011 !        k0 = 332*(2*2)/80
23012       Evan1cat=epscalc*(r012/(rcal**6))
23013       Evan2cat=epscalc*2*(r06/(rcal**3))
23014       Eeleccat=k0/ract
23015       r7 = rcal**7
23016       r4 = rcal**4
23017       r(1)=xj
23018       r(2)=yj
23019       r(3)=zj
23020       do k=1,3
23021         dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
23022         dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
23023         dEeleccat(k)=-k0*r(k)/ract**3
23024       enddo
23025       do k=1,3
23026         gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
23027         gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
23028         gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
23029       enddo
23030       if (energy_dec) write (iout,*) i,j,Evan1cat,Evan2cat,Eeleccat,&
23031        r012,rcal**6,ichargecat(itypi)*ichargecat(itypj)
23032 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
23033       ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
23034        enddo
23035        enddo
23036        return
23037        end subroutine ecatcat
23038 !---------------------------------------------------------------------------
23039 ! new for K+
23040       subroutine ecats_prot_amber(evdw)
23041 !      subroutine ecat_prot2(ecation_prot)
23042       use calc_data
23043       use comm_momo
23044
23045       logical :: lprn
23046 !el local variables
23047       integer :: iint,itypi1,subchap,isel,itmp
23048       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
23049       real(kind=8) :: evdw,aa,bb
23050       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23051                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
23052                 sslipi,sslipj,faclip,alpha_sco
23053       integer :: ii
23054       real(kind=8) :: fracinbuf
23055       real (kind=8) :: escpho
23056       real (kind=8),dimension(4):: ener
23057       real(kind=8) :: b1,b2,egb
23058       real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
23059        Lambf,&
23060        Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
23061        ecations_prot_amber,dFdOM2,dFdL,dFdOM12,&
23062        federmaus,&
23063        d1i,d1j
23064 !       real(kind=8),dimension(3,2)::erhead_tail
23065 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
23066       real(kind=8) ::  facd4, adler, Fgb, facd3
23067       integer troll,jj,istate
23068       real (kind=8) :: dcosom1(3),dcosom2(3)
23069       real(kind=8) ::locbox(3)
23070       locbox(1)=boxxsize
23071           locbox(2)=boxysize
23072       locbox(3)=boxzsize
23073
23074       evdw=0.0D0
23075       if (nres_molec(5).eq.0) return
23076       eps_out=80.0d0
23077 !      sss_ele_cut=1.0d0
23078
23079       itmp=0
23080       do i=1,4
23081       itmp=itmp+nres_molec(i)
23082       enddo
23083 !        go to 17
23084 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
23085       do i=ibond_start,ibond_end
23086
23087 !        print *,"I am in EVDW",i
23088       itypi=iabs(itype(i,1))
23089
23090 !        if (i.ne.47) cycle
23091       if ((itypi.eq.ntyp1).or.(itypi.eq.10)) cycle
23092       itypi1=iabs(itype(i+1,1))
23093       xi=c(1,nres+i)
23094       yi=c(2,nres+i)
23095       zi=c(3,nres+i)
23096       call to_box(xi,yi,zi)
23097       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
23098       dxi=dc_norm(1,nres+i)
23099       dyi=dc_norm(2,nres+i)
23100       dzi=dc_norm(3,nres+i)
23101       dsci_inv=vbld_inv(i+nres)
23102        do j=itmp+1,itmp+nres_molec(5)
23103
23104 ! Calculate SC interaction energy.
23105           itypj=iabs(itype(j,5))
23106           if ((itypj.eq.ntyp1)) cycle
23107            CALL elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
23108
23109           dscj_inv=0.0
23110          xj=c(1,j)
23111          yj=c(2,j)
23112          zj=c(3,j)
23113
23114       call to_box(xj,yj,zj)
23115 !      write(iout,*) "xi,yi,zi,xj,yj,zj", xi,yi,zi,xj,yj,zj
23116
23117 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
23118 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23119 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23120 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23121 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23122       xj=boxshift(xj-xi,boxxsize)
23123       yj=boxshift(yj-yi,boxysize)
23124       zj=boxshift(zj-zi,boxzsize)
23125 !      write(iout,*) "xj,yj,zj", xj,yj,zj,boxxsize
23126
23127 !          dxj = dc_norm( 1, nres+j )
23128 !          dyj = dc_norm( 2, nres+j )
23129 !          dzj = dc_norm( 3, nres+j )
23130
23131         itypi = itype(i,1)
23132         itypj = itype(j,5)
23133 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
23134 ! sampling performed with amber package
23135 !          alf1   = 0.0d0
23136 !          alf2   = 0.0d0
23137 !          alf12  = 0.0d0
23138 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
23139         chi1 = chi1cat(itypi,itypj)
23140         chis1 = chis1cat(itypi,itypj)
23141         chip1 = chipp1cat(itypi,itypj)
23142 !          chi1=0.0d0
23143 !          chis1=0.0d0
23144 !          chip1=0.0d0
23145         chi2=0.0
23146         chip2=0.0
23147         chis2=0.0
23148 !          chis2 = chis(itypj,itypi)
23149         chis12 = chis1 * chis2
23150         sig1 = sigmap1cat(itypi,itypj)
23151 !          sig2 = sigmap2(itypi,itypj)
23152 ! alpha factors from Fcav/Gcav
23153         b1cav = alphasurcat(1,itypi,itypj)
23154         b2cav = alphasurcat(2,itypi,itypj)
23155         b3cav = alphasurcat(3,itypi,itypj)
23156         b4cav = alphasurcat(4,itypi,itypj)
23157
23158 !        b1cav=0.0d0
23159 !        b2cav=0.0d0
23160 !        b3cav=0.0d0
23161 !        b4cav=0.0d0
23162
23163 ! used to determine whether we want to do quadrupole calculations
23164        eps_in = epsintabcat(itypi,itypj)
23165        if (eps_in.eq.0.0) eps_in=1.0
23166
23167        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23168 !       Rtail = 0.0d0
23169
23170        DO k = 1, 3
23171       ctail(k,1)=c(k,i+nres)
23172       ctail(k,2)=c(k,j)
23173        END DO
23174       call to_box(ctail(1,1),ctail(2,1),ctail(3,1))
23175       call to_box(ctail(1,2),ctail(2,2),ctail(3,2))
23176 !c! tail distances will be themselves usefull elswhere
23177 !c1 (in Gcav, for example)
23178        do k=1,3
23179        Rtail_distance(k) = boxshift(ctail(k,2) - ctail(k,1),locbox(k))
23180        enddo
23181        Rtail = dsqrt( &
23182         (Rtail_distance(1)*Rtail_distance(1)) &
23183       + (Rtail_distance(2)*Rtail_distance(2)) &
23184       + (Rtail_distance(3)*Rtail_distance(3)))
23185 ! tail location and distance calculations
23186 ! dhead1
23187        d1 = dheadcat(1, 1, itypi, itypj)
23188 !       d2 = dhead(2, 1, itypi, itypj)
23189        DO k = 1,3
23190 ! location of polar head is computed by taking hydrophobic centre
23191 ! and moving by a d1 * dc_norm vector
23192 ! see unres publications for very informative images
23193       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
23194       chead(k,2) = c(k, j)
23195       enddo
23196       call to_box(chead(1,1),chead(2,1),chead(3,1))
23197       call to_box(chead(1,2),chead(2,2),chead(3,2))
23198 !      write(iout,*) "TEST",chead(1,1),chead(2,1),chead(3,1),dc_norm(k, i+nres),d1
23199 ! distance
23200 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23201 !         Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23202       do k=1,3
23203       Rhead_distance(k) = boxshift(chead(k,2) - chead(k,1),locbox(k))
23204        END DO
23205 ! pitagoras (root of sum of squares)
23206        Rhead = dsqrt( &
23207         (Rhead_distance(1)*Rhead_distance(1)) &
23208       + (Rhead_distance(2)*Rhead_distance(2)) &
23209       + (Rhead_distance(3)*Rhead_distance(3)))
23210 !-------------------------------------------------------------------
23211 ! zero everything that should be zero'ed
23212        evdwij = 0.0d0
23213        ECL = 0.0d0
23214        Elj = 0.0d0
23215        Equad = 0.0d0
23216        Epol = 0.0d0
23217        Fcav=0.0d0
23218        eheadtail = 0.0d0
23219        dGCLdOM1 = 0.0d0
23220        dGCLdOM2 = 0.0d0
23221        dGCLdOM12 = 0.0d0
23222        dPOLdOM1 = 0.0d0
23223        dPOLdOM2 = 0.0d0
23224         Fcav = 0.0d0
23225         Fisocav=0.0d0
23226         dFdR = 0.0d0
23227         dCAVdOM1  = 0.0d0
23228         dCAVdOM2  = 0.0d0
23229         dCAVdOM12 = 0.0d0
23230         dscj_inv = vbld_inv(j+nres)
23231 !          print *,i,j,dscj_inv,dsci_inv
23232 ! rij holds 1/(distance of Calpha atoms)
23233         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23234         rij  = dsqrt(rrij)
23235         CALL sc_angular
23236 ! this should be in elgrad_init but om's are calculated by sc_angular
23237 ! which in turn is used by older potentials
23238 ! om = omega, sqom = om^2
23239         sqom1  = om1 * om1
23240         sqom2  = om2 * om2
23241         sqom12 = om12 * om12
23242
23243 ! now we calculate EGB - Gey-Berne
23244 ! It will be summed up in evdwij and saved in evdw
23245         sigsq     = 1.0D0  / sigsq
23246         sig       = sig0ij * dsqrt(sigsq)
23247 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23248         rij_shift = Rtail - sig + sig0ij
23249         IF (rij_shift.le.0.0D0) THEN
23250          evdw = 1.0D20
23251       if (evdw.gt.1.0d6) then
23252       write (*,'(2(1x,a3,i3),7f7.2)') &
23253       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23254       1.0d0/rij,Rtail,Rhead,rij_shift, sig, sig0ij,sigsq
23255       write(*,*) facsig,faceps1_inv,om1,chiom1,chi1
23256      write(*,*) "ANISO?!",chi1
23257 !evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23258 !      Equad,evdwij+Fcav+eheadtail,evdw
23259       endif
23260
23261          RETURN
23262         END IF
23263         sigder = -sig * sigsq
23264         rij_shift = 1.0D0 / rij_shift
23265         fac       = rij_shift**expon
23266         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
23267 !          print *,"ADAM",aa_aq(itypi,itypj)
23268
23269 !          c1        = 0.0d0
23270         c2        = fac  * bb_aq_cat(itypi,itypj)
23271 !          c2        = 0.0d0
23272         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23273         eps2der   = eps3rt * evdwij
23274         eps3der   = eps2rt * evdwij
23275 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23276         evdwij    = eps2rt * eps3rt * evdwij
23277 !#ifdef TSCSC
23278 !          IF (bb_aq(itypi,itypj).gt.0) THEN
23279 !           evdw_p = evdw_p + evdwij
23280 !          ELSE
23281 !           evdw_m = evdw_m + evdwij
23282 !          END IF
23283 !#else
23284         evdw = evdw  &
23285             + evdwij
23286 !#endif
23287         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23288         fac    = -expon * (c1 + evdwij) * rij_shift
23289         sigder = fac * sigder
23290 ! Calculate distance derivative
23291         gg(1) =  fac
23292         gg(2) =  fac
23293         gg(3) =  fac
23294 !       print *,"GG(1),distance grad",gg(1)
23295         fac = chis1 * sqom1 + chis2 * sqom2 &
23296         - 2.0d0 * chis12 * om1 * om2 * om12
23297         pom = 1.0d0 - chis1 * chis2 * sqom12
23298         Lambf = (1.0d0 - (fac / pom))
23299         Lambf = dsqrt(Lambf)
23300         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23301         Chif = Rtail * sparrow
23302         ChiLambf = Chif * Lambf
23303         eagle = dsqrt(ChiLambf)
23304         bat = ChiLambf ** 11.0d0
23305         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
23306         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
23307         botsq = bot * bot
23308         Fcav = top / bot
23309
23310        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
23311        dbot = 12.0d0 * b4cav * bat * Lambf
23312        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23313
23314         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
23315         dbot = 12.0d0 * b4cav * bat * Chif
23316         eagle = Lambf * pom
23317         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23318         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23319         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23320             * (chis2 * om2 * om12 - om1) / (eagle * pom)
23321
23322         dFdL = ((dtop * bot - top * dbot) / botsq)
23323         dCAVdOM1  = dFdL * ( dFdOM1 )
23324         dCAVdOM2  = dFdL * ( dFdOM2 )
23325         dCAVdOM12 = dFdL * ( dFdOM12 )
23326
23327        DO k= 1, 3
23328       ertail(k) = Rtail_distance(k)/Rtail
23329        END DO
23330        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
23331        erdxj = scalar( ertail(1), dC_norm(1,j) )
23332        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
23333        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j)
23334        DO k = 1, 3
23335       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23336       gradpepcatx(k,i) = gradpepcatx(k,i) &
23337               - (( dFdR + gg(k) ) * pom)
23338       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j))
23339 !        gvdwx(k,j) = gvdwx(k,j)   &
23340 !                  + (( dFdR + gg(k) ) * pom)
23341       gradpepcat(k,i) = gradpepcat(k,i)  &
23342               - (( dFdR + gg(k) ) * ertail(k))
23343       gradpepcat(k,j) = gradpepcat(k,j) &
23344               + (( dFdR + gg(k) ) * ertail(k))
23345       gg(k) = 0.0d0
23346        ENDDO
23347 !c! Compute head-head and head-tail energies for each state
23348 !!        if (.false.) then ! turn off electrostatic
23349         if (itype(j,5).gt.0) then ! the normal cation case
23350         isel = iabs(Qi) + 1 ! ion is always charged so  iabs(Qj)
23351 !        print *,i,itype(i,1),isel
23352         IF (isel.eq.0) THEN
23353 !c! No charges - do nothing
23354          eheadtail = 0.0d0
23355
23356         ELSE IF (isel.eq.1) THEN
23357 !c! Nonpolar-charge interactions
23358         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23359           Qi=Qi*2
23360           Qij=Qij*2
23361          endif
23362
23363          CALL enq_cat(epol)
23364          eheadtail = epol
23365 !           eheadtail = 0.0d0
23366
23367         ELSE IF (isel.eq.3) THEN
23368 !c! Dipole-charge interactions
23369         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23370           Qi=Qi*2
23371           Qij=Qij*2
23372          endif
23373 !         write(iout,*) "KURWA0",d1
23374
23375          CALL edq_cat(ecl, elj, epol)
23376         eheadtail = ECL + elj + epol
23377 !           eheadtail = 0.0d0
23378
23379         ELSE IF ((isel.eq.2)) THEN
23380
23381 !c! Same charge-charge interaction ( +/+ or -/- )
23382         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23383           Qi=Qi*2
23384           Qij=Qij*2
23385          endif
23386
23387          CALL eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
23388          eheadtail = ECL + Egb + Epol + Fisocav + Elj
23389 !           eheadtail = 0.0d0
23390
23391 !          ELSE IF ((isel.eq.2.and.  &
23392 !               iabs(Qi).eq.1).and. &
23393 !               nstate(itypi,itypj).ne.1) THEN
23394 !c! Different charge-charge interaction ( +/- or -/+ )
23395 !          if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23396 !            Qi=Qi*2
23397 !            Qij=Qij*2
23398 !           endif
23399 !          if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23400 !            Qj=Qj*2
23401 !            Qij=Qij*2
23402 !           endif
23403 !
23404 !           CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
23405        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
23406        else
23407        write(iout,*) "not yet implemented",j,itype(j,5)
23408        endif
23409 !!       endif ! turn off electrostatic
23410       evdw = evdw  + Fcav + eheadtail
23411 !      if (evdw.gt.1.0d6) then
23412 !      write (*,'(2(1x,a3,i3),3f6.2,10f16.7)') &
23413 !      restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23414 !      1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23415 !      Equad,evdwij+Fcav+eheadtail,evdw
23416 !      endif
23417
23418        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
23419       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23420       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23421       Equad,evdwij+Fcav+eheadtail,evdw
23422 !       evdw = evdw  + Fcav  + eheadtail
23423 !       print *,"before sc_grad_cat", i,j, gradpepcat(1,j)
23424 !        iF (nstate(itypi,itypj).eq.1) THEN
23425       CALL sc_grad_cat
23426 !       print *,"after sc_grad_cat", i,j, gradpepcat(1,j)
23427
23428 !       END IF
23429 !c!-------------------------------------------------------------------
23430 !c! NAPISY KONCOWE
23431        END DO   ! j
23432        END DO     ! i
23433 !c      write (iout,*) "Number of loop steps in EGB:",ind
23434 !c      energy_dec=.false.
23435 !              print *,"EVDW KURW",evdw,nres
23436 !!!        return
23437    17   continue
23438 !      go to 23
23439       do i=ibond_start,ibond_end
23440
23441 !        print *,"I am in EVDW",i
23442       itypi=10 ! the peptide group parameters are for glicine
23443
23444 !        if (i.ne.47) cycle
23445       if ((itype(i,1).eq.ntyp1).or.itype(i+1,1).eq.ntyp1) cycle
23446       itypi1=iabs(itype(i+1,1))
23447       xi=(c(1,i)+c(1,i+1))/2.0
23448       yi=(c(2,i)+c(2,i+1))/2.0
23449       zi=(c(3,i)+c(3,i+1))/2.0
23450         call to_box(xi,yi,zi)
23451       dxi=dc_norm(1,i)
23452       dyi=dc_norm(2,i)
23453       dzi=dc_norm(3,i)
23454       dsci_inv=vbld_inv(i+1)/2.0
23455        do j=itmp+1,itmp+nres_molec(5)
23456
23457 ! Calculate SC interaction energy.
23458           itypj=iabs(itype(j,5))
23459           if ((itypj.eq.ntyp1)) cycle
23460            CALL elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
23461
23462           dscj_inv=0.0
23463          xj=c(1,j)
23464          yj=c(2,j)
23465          zj=c(3,j)
23466         call to_box(xj,yj,zj)
23467       xj=boxshift(xj-xi,boxxsize)
23468       yj=boxshift(yj-yi,boxysize)
23469       zj=boxshift(zj-zi,boxzsize)
23470
23471         dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23472
23473         dxj = 0.0d0! dc_norm( 1, nres+j )
23474         dyj = 0.0d0!dc_norm( 2, nres+j )
23475         dzj = 0.0d0! dc_norm( 3, nres+j )
23476
23477         itypi = 10
23478         itypj = itype(j,5)
23479 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
23480 ! sampling performed with amber package
23481 !          alf1   = 0.0d0
23482 !          alf2   = 0.0d0
23483 !          alf12  = 0.0d0
23484 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
23485         chi1 = chi1cat(itypi,itypj)
23486         chis1 = chis1cat(itypi,itypj)
23487         chip1 = chipp1cat(itypi,itypj)
23488 !          chi1=0.0d0
23489 !          chis1=0.0d0
23490 !          chip1=0.0d0
23491         chi2=0.0
23492         chip2=0.0
23493         chis2=0.0
23494 !          chis2 = chis(itypj,itypi)
23495         chis12 = chis1 * chis2
23496         sig1 = sigmap1cat(itypi,itypj)
23497 !          sig2 = sigmap2(itypi,itypj)
23498 ! alpha factors from Fcav/Gcav
23499         b1cav = alphasurcat(1,itypi,itypj)
23500         b2cav = alphasurcat(2,itypi,itypj)
23501         b3cav = alphasurcat(3,itypi,itypj)
23502         b4cav = alphasurcat(4,itypi,itypj)
23503
23504 ! used to determine whether we want to do quadrupole calculations
23505        eps_in = epsintabcat(itypi,itypj)
23506        if (eps_in.eq.0.0) eps_in=1.0
23507
23508        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23509 !       Rtail = 0.0d0
23510
23511        DO k = 1, 3
23512       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0
23513       ctail(k,2)=c(k,j)
23514        END DO
23515       call to_box(ctail(1,1),ctail(2,1),ctail(3,1))
23516       call to_box(ctail(1,2),ctail(2,2),ctail(3,2))
23517 !c! tail distances will be themselves usefull elswhere
23518 !c1 (in Gcav, for example)
23519        do k=1,3
23520        Rtail_distance(k) = boxshift(ctail(k,2) - ctail(k,1),locbox(k))
23521        enddo
23522
23523 !c! tail distances will be themselves usefull elswhere
23524 !c1 (in Gcav, for example)
23525        Rtail = dsqrt( &
23526         (Rtail_distance(1)*Rtail_distance(1)) &
23527       + (Rtail_distance(2)*Rtail_distance(2)) &
23528       + (Rtail_distance(3)*Rtail_distance(3)))
23529 ! tail location and distance calculations
23530 ! dhead1
23531        d1 = dheadcat(1, 1, itypi, itypj)
23532 !       print *,"d1",d1
23533 !       d1=0.0d0
23534 !       d2 = dhead(2, 1, itypi, itypj)
23535        DO k = 1,3
23536 ! location of polar head is computed by taking hydrophobic centre
23537 ! and moving by a d1 * dc_norm vector
23538 ! see unres publications for very informative images
23539       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
23540       chead(k,2) = c(k, j)
23541        ENDDO
23542 ! distance
23543 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23544 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23545       call to_box(chead(1,1),chead(2,1),chead(3,1))
23546       call to_box(chead(1,2),chead(2,2),chead(3,2))
23547
23548 ! distance
23549 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23550 !         Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23551       do k=1,3
23552       Rhead_distance(k) = boxshift(chead(k,2) - chead(k,1),locbox(k))
23553        END DO
23554
23555 ! pitagoras (root of sum of squares)
23556        Rhead = dsqrt( &
23557         (Rhead_distance(1)*Rhead_distance(1)) &
23558       + (Rhead_distance(2)*Rhead_distance(2)) &
23559       + (Rhead_distance(3)*Rhead_distance(3)))
23560 !-------------------------------------------------------------------
23561 ! zero everything that should be zero'ed
23562        evdwij = 0.0d0
23563        ECL = 0.0d0
23564        Elj = 0.0d0
23565        Equad = 0.0d0
23566        Epol = 0.0d0
23567        Fcav=0.0d0
23568        eheadtail = 0.0d0
23569        dGCLdOM1 = 0.0d0
23570        dGCLdOM2 = 0.0d0
23571        dGCLdOM12 = 0.0d0
23572        dPOLdOM1 = 0.0d0
23573        dPOLdOM2 = 0.0d0
23574         Fcav = 0.0d0
23575         dFdR = 0.0d0
23576         dCAVdOM1  = 0.0d0
23577         dCAVdOM2  = 0.0d0
23578         dCAVdOM12 = 0.0d0
23579         dscj_inv = vbld_inv(j+nres)
23580 !          print *,i,j,dscj_inv,dsci_inv
23581 ! rij holds 1/(distance of Calpha atoms)
23582         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23583         rij  = dsqrt(rrij)
23584         CALL sc_angular
23585 ! this should be in elgrad_init but om's are calculated by sc_angular
23586 ! which in turn is used by older potentials
23587 ! om = omega, sqom = om^2
23588         sqom1  = om1 * om1
23589         sqom2  = om2 * om2
23590         sqom12 = om12 * om12
23591
23592 ! now we calculate EGB - Gey-Berne
23593 ! It will be summed up in evdwij and saved in evdw
23594         sigsq     = 1.0D0  / sigsq
23595         sig       = sig0ij * dsqrt(sigsq)
23596 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23597         rij_shift = Rtail - sig + sig0ij
23598         IF (rij_shift.le.0.0D0) THEN
23599          evdw = 1.0D20
23600 !      if (evdw.gt.1.0d6) then
23601 !      write (*,'(2(1x,a3,i3),6f6.2)') &
23602 !      restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23603 !      1.0d0/rij,Rtail,Rhead,rij_shift, sig, sig0ij
23604 !evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23605 !      Equad,evdwij+Fcav+eheadtail,evdw
23606 !      endif
23607          RETURN
23608         END IF
23609         sigder = -sig * sigsq
23610         rij_shift = 1.0D0 / rij_shift
23611         fac       = rij_shift**expon
23612         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
23613 !          print *,"ADAM",aa_aq(itypi,itypj)
23614
23615 !          c1        = 0.0d0
23616         c2        = fac  * bb_aq_cat(itypi,itypj)
23617 !          c2        = 0.0d0
23618         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23619         eps2der   = eps3rt * evdwij
23620         eps3der   = eps2rt * evdwij
23621 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23622         evdwij    = eps2rt * eps3rt * evdwij
23623 !#ifdef TSCSC
23624 !          IF (bb_aq(itypi,itypj).gt.0) THEN
23625 !           evdw_p = evdw_p + evdwij
23626 !          ELSE
23627 !           evdw_m = evdw_m + evdwij
23628 !          END IF
23629 !#else
23630         evdw = evdw  &
23631             + evdwij
23632 !#endif
23633         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23634         fac    = -expon * (c1 + evdwij) * rij_shift
23635         sigder = fac * sigder
23636 ! Calculate distance derivative
23637         gg(1) =  fac
23638         gg(2) =  fac
23639         gg(3) =  fac
23640
23641         fac = chis1 * sqom1 + chis2 * sqom2 &
23642         - 2.0d0 * chis12 * om1 * om2 * om12
23643
23644         pom = 1.0d0 - chis1 * chis2 * sqom12
23645 !          print *,"TUT2",fac,chis1,sqom1,pom
23646         Lambf = (1.0d0 - (fac / pom))
23647         Lambf = dsqrt(Lambf)
23648         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23649         Chif = Rtail * sparrow
23650         ChiLambf = Chif * Lambf
23651         eagle = dsqrt(ChiLambf)
23652         bat = ChiLambf ** 11.0d0
23653         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
23654         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
23655         botsq = bot * bot
23656         Fcav = top / bot
23657
23658        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
23659        dbot = 12.0d0 * b4cav * bat * Lambf
23660        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23661
23662         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
23663         dbot = 12.0d0 * b4cav * bat * Chif
23664         eagle = Lambf * pom
23665         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23666         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23667         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23668             * (chis2 * om2 * om12 - om1) / (eagle * pom)
23669
23670         dFdL = ((dtop * bot - top * dbot) / botsq)
23671         dCAVdOM1  = dFdL * ( dFdOM1 )
23672         dCAVdOM2  = dFdL * ( dFdOM2 )
23673         dCAVdOM12 = dFdL * ( dFdOM12 )
23674
23675        DO k= 1, 3
23676       ertail(k) = Rtail_distance(k)/Rtail
23677        END DO
23678        erdxi = scalar( ertail(1), dC_norm(1,i) )
23679        erdxj = scalar( ertail(1), dC_norm(1,j) )
23680        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i)
23681        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
23682        DO k = 1, 3
23683       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i))
23684 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
23685 !                  - (( dFdR + gg(k) ) * pom)
23686       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23687 !        gvdwx(k,j) = gvdwx(k,j)   &
23688 !                  + (( dFdR + gg(k) ) * pom)
23689       gradpepcat(k,i) = gradpepcat(k,i)  &
23690               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
23691       gradpepcat(k,i+1) = gradpepcat(k,i+1)  &
23692               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
23693
23694       gradpepcat(k,j) = gradpepcat(k,j) &
23695               + (( dFdR + gg(k) ) * ertail(k))
23696       gg(k) = 0.0d0
23697        ENDDO
23698       if (itype(j,5).gt.0) then
23699 !c! Compute head-head and head-tail energies for each state
23700         isel = 3
23701 !c! Dipole-charge interactions
23702          CALL edq_cat_pep(ecl, elj, epol)
23703          eheadtail = ECL + elj + epol
23704 !          print *,"i,",i,eheadtail
23705 !           eheadtail = 0.0d0
23706       else
23707 !HERE WATER and other types of molecules solvents will be added
23708       write(iout,*) "not yet implemented"
23709 !      CALL edd_cat_pep
23710       endif
23711       evdw = evdw  + Fcav + eheadtail
23712 !      if (evdw.gt.1.0d6) then
23713 !      write (*,'(2(1x,a3,i3),3f6.2,10f16.7)') &
23714 !      restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23715 !      1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23716 !      Equad,evdwij+Fcav+eheadtail,evdw
23717 !      endif
23718        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
23719       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23720       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23721       Equad,evdwij+Fcav+eheadtail,evdw
23722 !       evdw = evdw  + Fcav  + eheadtail
23723
23724 !        iF (nstate(itypi,itypj).eq.1) THEN
23725       CALL sc_grad_cat_pep
23726 !       END IF
23727 !c!-------------------------------------------------------------------
23728 !c! NAPISY KONCOWE
23729        END DO   ! j
23730        END DO     ! i
23731 !c      write (iout,*) "Number of loop steps in EGB:",ind
23732 !c      energy_dec=.false.
23733 !              print *,"EVDW KURW",evdw,nres
23734  23   continue
23735 !       print *,"before leave sc_grad_cat", i,j, gradpepcat(1,nres-1)
23736
23737       return
23738       end subroutine ecats_prot_amber
23739
23740 !---------------------------------------------------------------------------
23741 ! old for Ca2+
23742        subroutine ecat_prot(ecation_prot)
23743 !      use calc_data
23744 !      use comm_momo
23745        integer i,j,k,subchap,itmp,inum
23746       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
23747       r7,r4,ecationcation
23748       real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
23749       dist_init,dist_temp,ecation_prot,rcal,rocal,   &
23750       Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
23751       catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
23752       wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
23753       costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
23754       Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
23755       rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
23756       opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
23757       opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
23758       Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip,&
23759       ndiv,ndivi
23760       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
23761       gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
23762       dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
23763       tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
23764       v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
23765       dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
23766       dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
23767       dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
23768       dEvan1Cat
23769       real(kind=8),dimension(6) :: vcatprm
23770       ecation_prot=0.0d0
23771 ! first lets calculate interaction with peptide groups
23772       if (nres_molec(5).eq.0) return
23773       itmp=0
23774       do i=1,4
23775       itmp=itmp+nres_molec(i)
23776       enddo
23777 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
23778       do i=ibond_start,ibond_end
23779 !         cycle
23780        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
23781       xi=0.5d0*(c(1,i)+c(1,i+1))
23782       yi=0.5d0*(c(2,i)+c(2,i+1))
23783       zi=0.5d0*(c(3,i)+c(3,i+1))
23784         call to_box(xi,yi,zi)
23785
23786        do j=itmp+1,itmp+nres_molec(5)
23787 !           print *,"WTF",itmp,j,i
23788 ! all parameters were for Ca2+ to approximate single charge divide by two
23789        ndiv=1.0
23790        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23791        wconst=78*ndiv
23792       wdip =1.092777950857032D2
23793       wdip=wdip/wconst
23794       wmodquad=-2.174122713004870D4
23795       wmodquad=wmodquad/wconst
23796       wquad1 = 3.901232068562804D1
23797       wquad1=wquad1/wconst
23798       wquad2 = 3
23799       wquad2=wquad2/wconst
23800       wvan1 = 0.1
23801       wvan2 = 6
23802 !        itmp=0
23803
23804          xj=c(1,j)
23805          yj=c(2,j)
23806          zj=c(3,j)
23807         call to_box(xj,yj,zj)
23808       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23809 !       enddo
23810 !       enddo
23811        rcpm = sqrt(xj**2+yj**2+zj**2)
23812        drcp_norm(1)=xj/rcpm
23813        drcp_norm(2)=yj/rcpm
23814        drcp_norm(3)=zj/rcpm
23815        dcmag=0.0
23816        do k=1,3
23817        dcmag=dcmag+dc(k,i)**2
23818        enddo
23819        dcmag=dsqrt(dcmag)
23820        do k=1,3
23821        myd_norm(k)=dc(k,i)/dcmag
23822        enddo
23823       costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
23824       drcp_norm(3)*myd_norm(3)
23825       rsecp = rcpm**2
23826       Ir = 1.0d0/rcpm
23827       Irsecp = 1.0d0/rsecp
23828       Irthrp = Irsecp/rcpm
23829       Irfourp = Irthrp/rcpm
23830       Irfiftp = Irfourp/rcpm
23831       Irsistp=Irfiftp/rcpm
23832       Irseven=Irsistp/rcpm
23833       Irtwelv=Irsistp*Irsistp
23834       Irthir=Irtwelv/rcpm
23835       sin2thet = (1-costhet*costhet)
23836       sinthet=sqrt(sin2thet)
23837       E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
23838            *sin2thet
23839       E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
23840            2*wvan2**6*Irsistp)
23841       ecation_prot = ecation_prot+E1+E2
23842 !        print *,"ecatprot",i,j,ecation_prot,rcpm
23843       dE1dr = -2*costhet*wdip*Irthrp-&
23844        (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
23845       dE2dr = 3*wquad1*wquad2*Irfourp-     &
23846         12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
23847       dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
23848       do k=1,3
23849         drdpep(k) = -drcp_norm(k)
23850         dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
23851         dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
23852         dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
23853         dEddci(k) = dEdcos*dcosddci(k)
23854       enddo
23855       do k=1,3
23856       gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
23857       gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
23858       gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
23859       enddo
23860        enddo ! j
23861        enddo ! i
23862 !------------------------------------------sidechains
23863 !        do i=1,nres_molec(1)
23864       do i=ibond_start,ibond_end
23865        if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
23866 !         cycle
23867 !        print *,i,ecation_prot
23868       xi=(c(1,i+nres))
23869       yi=(c(2,i+nres))
23870       zi=(c(3,i+nres))
23871                 call to_box(xi,yi,zi)
23872         do k=1,3
23873           cm1(k)=dc(k,i+nres)
23874         enddo
23875          cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
23876        do j=itmp+1,itmp+nres_molec(5)
23877        ndiv=1.0
23878        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23879
23880          xj=c(1,j)
23881          yj=c(2,j)
23882          zj=c(3,j)
23883         call to_box(xj,yj,zj)
23884       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23885 !       enddo
23886 !       enddo
23887 ! 15- Glu 16-Asp
23888        if((itype(i,1).eq.15.or.itype(i,1).eq.16).or.&
23889        ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.&
23890        (itype(i,1).eq.25))) then
23891           if(itype(i,1).eq.16) then
23892           inum=1
23893           else
23894           inum=2
23895           endif
23896           do k=1,6
23897           vcatprm(k)=catprm(k,inum)
23898           enddo
23899           dASGL=catprm(7,inum)
23900 !             do k=1,3
23901 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23902             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23903             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23904             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23905
23906 !                valpha(k)=c(k,i)
23907 !                vcat(k)=c(k,j)
23908             if (subchap.eq.1) then
23909              vcat(1)=xj_temp
23910              vcat(2)=yj_temp
23911              vcat(3)=zj_temp
23912              else
23913             vcat(1)=xj_safe
23914             vcat(2)=yj_safe
23915             vcat(3)=zj_safe
23916              endif
23917             valpha(1)=xi-c(1,i+nres)+c(1,i)
23918             valpha(2)=yi-c(2,i+nres)+c(2,i)
23919             valpha(3)=zi-c(3,i+nres)+c(3,i)
23920
23921 !              enddo
23922       do k=1,3
23923         dx(k) = vcat(k)-vcm(k)
23924       enddo
23925       do k=1,3
23926         v1(k)=(vcm(k)-valpha(k))
23927         v2(k)=(vcat(k)-valpha(k))
23928       enddo
23929       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23930       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23931       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23932
23933 !  The weights of the energy function calculated from
23934 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
23935         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23936           ndivi=0.5
23937         else
23938           ndivi=1.0
23939         endif
23940        ndiv=1.0
23941        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23942
23943       wh2o=78*ndivi*ndiv
23944       wc = vcatprm(1)
23945       wc=wc/wh2o
23946       wdip =vcatprm(2)
23947       wdip=wdip/wh2o
23948       wquad1 =vcatprm(3)
23949       wquad1=wquad1/wh2o
23950       wquad2 = vcatprm(4)
23951       wquad2=wquad2/wh2o
23952       wquad2p = 1.0d0-wquad2
23953       wvan1 = vcatprm(5)
23954       wvan2 =vcatprm(6)
23955       opt = dx(1)**2+dx(2)**2
23956       rsecp = opt+dx(3)**2
23957       rs = sqrt(rsecp)
23958       rthrp = rsecp*rs
23959       rfourp = rthrp*rs
23960       rsixp = rfourp*rsecp
23961       reight=rsixp*rsecp
23962       Ir = 1.0d0/rs
23963       Irsecp = 1.0d0/rsecp
23964       Irthrp = Irsecp/rs
23965       Irfourp = Irthrp/rs
23966       Irsixp = 1.0d0/rsixp
23967       Ireight=1.0d0/reight
23968       Irtw=Irsixp*Irsixp
23969       Irthir=Irtw/rs
23970       Irfourt=Irthir/rs
23971       opt1 = (4*rs*dx(3)*wdip)
23972       opt2 = 6*rsecp*wquad1*opt
23973       opt3 = wquad1*wquad2p*Irsixp
23974       opt4 = (wvan1*wvan2**12)
23975       opt5 = opt4*12*Irfourt
23976       opt6 = 2*wvan1*wvan2**6
23977       opt7 = 6*opt6*Ireight
23978       opt8 = wdip/v1m
23979       opt10 = wdip/v2m
23980       opt11 = (rsecp*v2m)**2
23981       opt12 = (rsecp*v1m)**2
23982       opt14 = (v1m*v2m*rsecp)**2
23983       opt15 = -wquad1/v2m**2
23984       opt16 = (rthrp*(v1m*v2m)**2)**2
23985       opt17 = (v1m**2*rthrp)**2
23986       opt18 = -wquad1/rthrp
23987       opt19 = (v1m**2*v2m**2)**2
23988       Ec = wc*Ir
23989       do k=1,3
23990         dEcCat(k) = -(dx(k)*wc)*Irthrp
23991         dEcCm(k)=(dx(k)*wc)*Irthrp
23992         dEcCalp(k)=0.0d0
23993       enddo
23994       Edip=opt8*(v1dpv2)/(rsecp*v2m)
23995       do k=1,3
23996         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
23997                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23998         dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
23999                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
24000         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
24001                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
24002                   *v1dpv2)/opt14
24003       enddo
24004       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
24005       do k=1,3
24006         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
24007                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
24008                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
24009         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
24010                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
24011                   v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
24012         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
24013                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
24014                   v1dpv2**2)/opt19
24015       enddo
24016       Equad2=wquad1*wquad2p*Irthrp
24017       do k=1,3
24018         dEquad2Cat(k)=-3*dx(k)*rs*opt3
24019         dEquad2Cm(k)=3*dx(k)*rs*opt3
24020         dEquad2Calp(k)=0.0d0
24021       enddo
24022       Evan1=opt4*Irtw
24023       do k=1,3
24024         dEvan1Cat(k)=-dx(k)*opt5
24025         dEvan1Cm(k)=dx(k)*opt5
24026         dEvan1Calp(k)=0.0d0
24027       enddo
24028       Evan2=-opt6*Irsixp
24029       do k=1,3
24030         dEvan2Cat(k)=dx(k)*opt7
24031         dEvan2Cm(k)=-dx(k)*opt7
24032         dEvan2Calp(k)=0.0d0
24033       enddo
24034       ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
24035 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
24036
24037       do k=1,3
24038         dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
24039                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
24040 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
24041         dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
24042                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
24043         dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
24044                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
24045       enddo
24046           dscmag = 0.0d0
24047           do k=1,3
24048             dscvec(k) = dc(k,i+nres)
24049             dscmag = dscmag+dscvec(k)*dscvec(k)
24050           enddo
24051           dscmag3 = dscmag
24052           dscmag = sqrt(dscmag)
24053           dscmag3 = dscmag3*dscmag
24054           constA = 1.0d0+dASGL/dscmag
24055           constB = 0.0d0
24056           do k=1,3
24057             constB = constB+dscvec(k)*dEtotalCm(k)
24058           enddo
24059           constB = constB*dASGL/dscmag3
24060           do k=1,3
24061             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
24062             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
24063              constA*dEtotalCm(k)-constB*dscvec(k)
24064 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
24065             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
24066             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
24067            enddo
24068       else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
24069          if(itype(i,1).eq.14) then
24070           inum=3
24071           else
24072           inum=4
24073           endif
24074           do k=1,6
24075           vcatprm(k)=catprm(k,inum)
24076           enddo
24077           dASGL=catprm(7,inum)
24078 !             do k=1,3
24079 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
24080 !                valpha(k)=c(k,i)
24081 !                vcat(k)=c(k,j)
24082 !              enddo
24083             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
24084             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
24085             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
24086             if (subchap.eq.1) then
24087              vcat(1)=xj_temp
24088              vcat(2)=yj_temp
24089              vcat(3)=zj_temp
24090              else
24091             vcat(1)=xj_safe
24092             vcat(2)=yj_safe
24093             vcat(3)=zj_safe
24094             endif
24095             valpha(1)=xi-c(1,i+nres)+c(1,i)
24096             valpha(2)=yi-c(2,i+nres)+c(2,i)
24097             valpha(3)=zi-c(3,i+nres)+c(3,i)
24098
24099
24100       do k=1,3
24101         dx(k) = vcat(k)-vcm(k)
24102       enddo
24103       do k=1,3
24104         v1(k)=(vcm(k)-valpha(k))
24105         v2(k)=(vcat(k)-valpha(k))
24106       enddo
24107       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
24108       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
24109       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
24110 !  The weights of the energy function calculated from
24111 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
24112        ndiv=1.0
24113        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
24114
24115       wh2o=78*ndiv
24116       wdip =vcatprm(2)
24117       wdip=wdip/wh2o
24118       wquad1 =vcatprm(3)
24119       wquad1=wquad1/wh2o
24120       wquad2 = vcatprm(4)
24121       wquad2=wquad2/wh2o
24122       wquad2p = 1-wquad2
24123       wvan1 = vcatprm(5)
24124       wvan2 =vcatprm(6)
24125       opt = dx(1)**2+dx(2)**2
24126       rsecp = opt+dx(3)**2
24127       rs = sqrt(rsecp)
24128       rthrp = rsecp*rs
24129       rfourp = rthrp*rs
24130       rsixp = rfourp*rsecp
24131       reight=rsixp*rsecp
24132       Ir = 1.0d0/rs
24133       Irsecp = 1/rsecp
24134       Irthrp = Irsecp/rs
24135       Irfourp = Irthrp/rs
24136       Irsixp = 1/rsixp
24137       Ireight=1/reight
24138       Irtw=Irsixp*Irsixp
24139       Irthir=Irtw/rs
24140       Irfourt=Irthir/rs
24141       opt1 = (4*rs*dx(3)*wdip)
24142       opt2 = 6*rsecp*wquad1*opt
24143       opt3 = wquad1*wquad2p*Irsixp
24144       opt4 = (wvan1*wvan2**12)
24145       opt5 = opt4*12*Irfourt
24146       opt6 = 2*wvan1*wvan2**6
24147       opt7 = 6*opt6*Ireight
24148       opt8 = wdip/v1m
24149       opt10 = wdip/v2m
24150       opt11 = (rsecp*v2m)**2
24151       opt12 = (rsecp*v1m)**2
24152       opt14 = (v1m*v2m*rsecp)**2
24153       opt15 = -wquad1/v2m**2
24154       opt16 = (rthrp*(v1m*v2m)**2)**2
24155       opt17 = (v1m**2*rthrp)**2
24156       opt18 = -wquad1/rthrp
24157       opt19 = (v1m**2*v2m**2)**2
24158       Edip=opt8*(v1dpv2)/(rsecp*v2m)
24159       do k=1,3
24160         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
24161                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
24162        dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
24163                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
24164         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
24165                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
24166                   *v1dpv2)/opt14
24167       enddo
24168       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
24169       do k=1,3
24170         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
24171                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
24172                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
24173         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
24174                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
24175                    v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
24176         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
24177                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
24178                   v1dpv2**2)/opt19
24179       enddo
24180       Equad2=wquad1*wquad2p*Irthrp
24181       do k=1,3
24182         dEquad2Cat(k)=-3*dx(k)*rs*opt3
24183         dEquad2Cm(k)=3*dx(k)*rs*opt3
24184         dEquad2Calp(k)=0.0d0
24185       enddo
24186       Evan1=opt4*Irtw
24187       do k=1,3
24188         dEvan1Cat(k)=-dx(k)*opt5
24189         dEvan1Cm(k)=dx(k)*opt5
24190         dEvan1Calp(k)=0.0d0
24191       enddo
24192       Evan2=-opt6*Irsixp
24193       do k=1,3
24194         dEvan2Cat(k)=dx(k)*opt7
24195         dEvan2Cm(k)=-dx(k)*opt7
24196         dEvan2Calp(k)=0.0d0
24197       enddo
24198        ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
24199       do k=1,3
24200         dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
24201                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
24202         dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
24203                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
24204         dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
24205                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
24206       enddo
24207           dscmag = 0.0d0
24208           do k=1,3
24209             dscvec(k) = c(k,i+nres)-c(k,i)
24210 ! TU SPRAWDZ???
24211 !              dscvec(1) = xj
24212 !              dscvec(2) = yj
24213 !              dscvec(3) = zj
24214
24215             dscmag = dscmag+dscvec(k)*dscvec(k)
24216           enddo
24217           dscmag3 = dscmag
24218           dscmag = sqrt(dscmag)
24219           dscmag3 = dscmag3*dscmag
24220           constA = 1+dASGL/dscmag
24221           constB = 0.0d0
24222           do k=1,3
24223             constB = constB+dscvec(k)*dEtotalCm(k)
24224           enddo
24225           constB = constB*dASGL/dscmag3
24226           do k=1,3
24227             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
24228             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
24229              constA*dEtotalCm(k)-constB*dscvec(k)
24230             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
24231             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
24232            enddo
24233          else
24234           rcal = 0.0d0
24235           do k=1,3
24236 !              r(k) = c(k,j)-c(k,i+nres)
24237             r(1) = xj
24238             r(2) = yj
24239             r(3) = zj
24240             rcal = rcal+r(k)*r(k)
24241           enddo
24242           ract=sqrt(rcal)
24243           rocal=1.5
24244           epscalc=0.2
24245           r0p=0.5*(rocal+sig0(itype(i,1)))
24246           r06 = r0p**6
24247           r012 = r06*r06
24248           Evan1=epscalc*(r012/rcal**6)
24249           Evan2=epscalc*2*(r06/rcal**3)
24250           r4 = rcal**4
24251           r7 = rcal**7
24252           do k=1,3
24253             dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
24254             dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
24255           enddo
24256           do k=1,3
24257             dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
24258           enddo
24259              ecation_prot = ecation_prot+ Evan1+Evan2
24260           do  k=1,3
24261              gradpepcatx(k,i)=gradpepcatx(k,i)+ &
24262              dEtotalCm(k)
24263             gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
24264             gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
24265            enddo
24266        endif ! 13-16 residues
24267        enddo !j
24268        enddo !i
24269        return
24270        end subroutine ecat_prot
24271
24272 !----------------------------------------------------------------------------
24273 !---------------------------------------------------------------------------
24274        subroutine ecat_nucl(ecation_nucl)
24275        integer i,j,k,subchap,itmp,inum,itypi,itypj
24276        real(kind=8) :: xi,yi,zi,xj,yj,zj
24277        real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
24278        dist_init,dist_temp,ecation_nucl,Evan1,Evan2,Ecav,Egb,wdip1,wdip2, &
24279        wvan1,wvan2,wgbsig,wgbeps,wgbchi,wgbchip,wcav1,wcav2,wcav3,wcav4, &
24280        wcavsig,wcavchi,v1m,v1dpdx,wh2o,wc,Edip,rcs2,invrcs6,invrcs8,invrcs12, &
24281        invrcs14,rcb,rcb2,invrcb,invrcb2,invrcb4,invrcb6,cosinus,cos2,dcosdcatconst, &
24282        dcosdcalpconst,dcosdcmconst,rcav,rcav11,rcav12,constcav1,constcav2, &
24283        constgb1,constgb2,constdvan1,constdvan2,sgb,sgb6,sgb7,sgb12,sgb13, &
24284        cavnum,cavdenom,invcavdenom2,dcavnumdcos,dcavnumdr,dcavdenomdcos, &
24285        dcavdenomdr,sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
24286        real(kind=8),dimension(3) ::gg,r,dEtotalCm,dEtotalCalp,dEvan1Cm,&
24287        dEvan2Cm,cm1,cm,vcat,vsug,v1,v2,dx,vcm,dEdipCm,dEdipCalp, &
24288        dEvan1Calp,dEvan2Cat,dEvan2Calp,dEtotalCat,dEdipCat,dEvan1Cat,dcosdcat, &
24289        dcosdcalp,dcosdcm,dEgbdCat,dEgbdCalp,dEgbdCm,dEcavdCat,dEcavdCalp, &
24290        dEcavdCm,boxik
24291        real(kind=8),dimension(14) :: vcatnuclprm
24292        ecation_nucl=0.0d0
24293        boxik(1)=boxxsize
24294        boxik(2)=boxysize
24295        boxik(3)=boxzsize
24296
24297        if (nres_molec(5).eq.0) return
24298        itmp=0
24299        do i=1,4
24300           itmp=itmp+nres_molec(i)
24301        enddo
24302        do i=iatsc_s_nucl,iatsc_e_nucl
24303           if ((itype(i,2).eq.ntyp1_molec(2))) cycle ! leave dummy atoms
24304           xi=(c(1,i+nres))
24305           yi=(c(2,i+nres))
24306           zi=(c(3,i+nres))
24307       call to_box(xi,yi,zi)
24308       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
24309           do k=1,3
24310              cm1(k)=dc(k,i+nres)
24311           enddo
24312           do j=itmp+1,itmp+nres_molec(5)
24313              xj=c(1,j)
24314              yj=c(2,j)
24315              zj=c(3,j)
24316       call to_box(xj,yj,zj)
24317 !      write(iout,*) "xi,yi,zi,xj,yj,zj", xi,yi,zi,xj,yj,zj
24318 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
24319 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24320 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24321 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24322 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24323       xj=boxshift(xj-xi,boxxsize)
24324       yj=boxshift(yj-yi,boxysize)
24325       zj=boxshift(zj-zi,boxzsize)
24326 !       write(iout,*) 'after shift', xj,yj,zj
24327              dist_init=xj**2+yj**2+zj**2
24328
24329              itypi=itype(i,2)
24330              itypj=itype(j,5)
24331              do k=1,13
24332                 vcatnuclprm(k)=catnuclprm(k,itypi,itypj)
24333              enddo
24334              do k=1,3
24335                 vcm(k)=c(k,i+nres)
24336                 vsug(k)=c(k,i)
24337                 vcat(k)=c(k,j)
24338              enddo
24339              call to_box(vcm(1),vcm(2),vcm(3))
24340              call to_box(vsug(1),vsug(2),vsug(3))
24341              call to_box(vcat(1),vcat(2),vcat(3))
24342              do k=1,3
24343 !                dx(k) = vcat(k)-vcm(k)
24344 !             enddo
24345                 dx(k)=boxshift(vcat(k)-vcm(k),boxik(k))
24346 !             do k=1,3
24347                 v1(k)=dc(k,i+nres)
24348                 v2(k)=boxshift(vcat(k)-vsug(k),boxik(k))
24349              enddo
24350              v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
24351              v1dpdx = v1(1)*dx(1)+v1(2)*dx(2)+v1(3)*dx(3)
24352 !  The weights of the energy function calculated from
24353 !The quantum mechanical Gaussian simulations of potassium and sodium with deoxynucleosides
24354              wh2o=78
24355              wdip1 = vcatnuclprm(1)
24356              wdip1 = wdip1/wh2o                     !w1
24357              wdip2 = vcatnuclprm(2)
24358              wdip2 = wdip2/wh2o                     !w2
24359              wvan1 = vcatnuclprm(3)
24360              wvan2 = vcatnuclprm(4)                 !pis1
24361              wgbsig = vcatnuclprm(5)                !sigma0
24362              wgbeps = vcatnuclprm(6)                !epsi0
24363              wgbchi = vcatnuclprm(7)                !chi1
24364              wgbchip = vcatnuclprm(8)               !chip1
24365              wcavsig = vcatnuclprm(9)               !sig
24366              wcav1 = vcatnuclprm(10)                !b1
24367              wcav2 = vcatnuclprm(11)                !b2
24368              wcav3 = vcatnuclprm(12)                !b3
24369              wcav4 = vcatnuclprm(13)                !b4
24370              wcavchi = vcatnuclprm(14)              !chis1
24371              rcs2 = v2(1)**2+v2(2)**2+v2(3)**2
24372              invrcs6 = 1/rcs2**3
24373              invrcs8 = invrcs6/rcs2
24374              invrcs12 = invrcs6**2
24375              invrcs14 = invrcs12/rcs2
24376              rcb2 = dx(1)**2+dx(2)**2+dx(3)**2
24377              rcb = sqrt(rcb2)
24378              invrcb = 1/rcb
24379              invrcb2 = invrcb**2
24380              invrcb4 = invrcb2**2
24381              invrcb6 = invrcb4*invrcb2
24382              cosinus = v1dpdx/(v1m*rcb)
24383              cos2 = cosinus**2
24384              dcosdcatconst = invrcb2/v1m
24385              dcosdcalpconst = invrcb/v1m**2
24386              dcosdcmconst = invrcb2/v1m**2
24387              do k=1,3
24388                 dcosdcat(k) = (v1(k)*rcb-dx(k)*v1m*cosinus)*dcosdcatconst
24389                 dcosdcalp(k) = (v1(k)*rcb*cosinus-dx(k)*v1m)*dcosdcalpconst
24390                 dcosdcm(k) = ((dx(k)-v1(k))*v1m*rcb+ &
24391                         cosinus*(dx(k)*v1m**2-v1(k)*rcb2))*dcosdcmconst
24392              enddo
24393              rcav = rcb/wcavsig
24394              rcav11 = rcav**11
24395              rcav12 = rcav11*rcav
24396              constcav1 = 1-wcavchi*cos2
24397              constcav2 = sqrt(constcav1)
24398              constgb1 = 1/sqrt(1-wgbchi*cos2)
24399              constgb2 = wgbeps*(1-wgbchip*cos2)**2
24400              constdvan1 = 12*wvan1*wvan2**12*invrcs14
24401              constdvan2 = 6*wvan1*wvan2**6*invrcs8
24402 !----------------------------------------------------------------------------
24403 !Gay-Berne term
24404 !---------------------------------------------------------------------------
24405              sgb = 1/(1-constgb1+(rcb/wgbsig))
24406              sgb6 = sgb**6
24407              sgb7 = sgb6*sgb
24408              sgb12 = sgb6**2
24409              sgb13 = sgb12*sgb
24410              Egb = constgb2*(sgb12-sgb6)
24411              do k=1,3
24412                 dEgbdCat(k) = -constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) &
24413                  +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) &
24414      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcat(k)
24415                 dEgbdCm(k) = constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) &
24416                  +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) &
24417      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcm(k)
24418                 dEgbdCalp(k) = (constgb1**3*constgb2*wgbchi*cosinus &
24419                                *(12*sgb13-6*sgb7) &
24420      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcalp(k)
24421              enddo
24422 !----------------------------------------------------------------------------
24423 !cavity term
24424 !---------------------------------------------------------------------------
24425              cavnum = sqrt(rcav*constcav2)+wcav2*rcav*constcav2-wcav3
24426              cavdenom = 1+wcav4*rcav12*constcav1**6
24427              Ecav = wcav1*cavnum/cavdenom
24428              invcavdenom2 = 1/cavdenom**2
24429              dcavnumdcos = -wcavchi*cosinus/constcav2 &
24430                     *(sqrt(rcav/constcav2)/2+wcav2*rcav)
24431              dcavnumdr = (0.5*sqrt(constcav2/rcav)+wcav2*constcav2)/wcavsig
24432              dcavdenomdcos = -12*wcav4*wcavchi*rcav12*constcav1**5*cosinus
24433              dcavdenomdr = 12*wcav4/wcavsig*rcav11*constcav1**6
24434              do k=1,3
24435                 dEcavdCat(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
24436      *dcosdcat(k)+(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2
24437                 dEcavdCm(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
24438      *dcosdcm(k)-(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2
24439                 dEcavdCalp(k) = (dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
24440                              *dcosdcalp(k)*wcav1*invcavdenom2
24441              enddo
24442 !----------------------------------------------------------------------------
24443 !van der Waals and dipole-charge interaction energy
24444 !---------------------------------------------------------------------------
24445              Evan1 = wvan1*wvan2**12*invrcs12
24446              do k=1,3
24447                 dEvan1Cat(k) = -v2(k)*constdvan1
24448                 dEvan1Cm(k) = 0.0d0
24449                 dEvan1Calp(k) = v2(k)*constdvan1
24450              enddo
24451              Evan2 = -wvan1*wvan2**6*invrcs6
24452              do k=1,3
24453                 dEvan2Cat(k) = v2(k)*constdvan2
24454                 dEvan2Cm(k) = 0.0d0
24455                 dEvan2Calp(k) = -v2(k)*constdvan2
24456              enddo
24457              Edip = wdip1*cosinus*invrcb2-wdip2*(1-cos2)*invrcb4
24458              do k=1,3
24459                 dEdipCat(k) = (-2*wdip1*cosinus*invrcb4 &
24460                                +4*wdip2*(1-cos2)*invrcb6)*dx(k) &
24461                    +dcosdcat(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4)
24462                 dEdipCm(k) = (2*wdip1*cosinus*invrcb4 &
24463                              -4*wdip2*(1-cos2)*invrcb6)*dx(k) &
24464                    +dcosdcm(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4)
24465                 dEdipCalp(k) = dcosdcalp(k)*(wdip1*invrcb2 &
24466                                   +2*wdip2*cosinus*invrcb4)
24467              enddo
24468              if (energy_dec) write (iout,'(2i5,4(a6,f7.3))') i,j, &
24469          ' E GB ',Egb,' ECav ',Ecav,' Evdw ',Evan1+Evan2,' Edip ',Edip
24470              ecation_nucl=ecation_nucl+Ecav+Egb+Edip+Evan1+Evan2
24471              do k=1,3
24472                 dEtotalCat(k) = dEcavdCat(k)+dEvan1Cat(k)+dEvan2Cat(k) &
24473                                              +dEgbdCat(k)+dEdipCat(k)
24474                 dEtotalCm(k) = dEcavdCm(k)+dEvan1Cm(k)+dEvan2Cm(k) &
24475                                            +dEgbdCm(k)+dEdipCm(k)
24476                 dEtotalCalp(k) = dEcavdCalp(k)+dEgbdCalp(k)+dEvan1Calp(k) &
24477                                              +dEdipCalp(k)+dEvan2Calp(k)
24478              enddo
24479              do k=1,3
24480                 gg(k) = dEtotalCm(k)+dEtotalCalp(k)
24481                 gradnuclcatx(k,i)=gradnuclcatx(k,i)+dEtotalCm(k)
24482                 gradnuclcat(k,i)=gradnuclcat(k,i)+gg(k)
24483                 gradnuclcat(k,j)=gradnuclcat(k,j)+dEtotalCat(k)
24484              enddo
24485           enddo !j
24486        enddo !i
24487        return
24488        end subroutine ecat_nucl
24489
24490 !-----------------------------------------------------------------------------
24491 !-----------------------------------------------------------------------------
24492       subroutine eprot_sc_base(escbase)
24493       use calc_data
24494 !      implicit real*8 (a-h,o-z)
24495 !      include 'DIMENSIONS'
24496 !      include 'COMMON.GEO'
24497 !      include 'COMMON.VAR'
24498 !      include 'COMMON.LOCAL'
24499 !      include 'COMMON.CHAIN'
24500 !      include 'COMMON.DERIV'
24501 !      include 'COMMON.NAMES'
24502 !      include 'COMMON.INTERACT'
24503 !      include 'COMMON.IOUNITS'
24504 !      include 'COMMON.CALC'
24505 !      include 'COMMON.CONTROL'
24506 !      include 'COMMON.SBRIDGE'
24507       logical :: lprn
24508 !el local variables
24509       integer :: iint,itypi,itypi1,itypj,subchap
24510       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24511       real(kind=8) :: evdw,sig0ij
24512       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24513                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24514                 sslipi,sslipj,faclip
24515       integer :: ii
24516       real(kind=8) :: fracinbuf
24517        real (kind=8) :: escbase
24518        real (kind=8),dimension(4):: ener
24519        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24520        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24521       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
24522       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24523       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
24524       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24525       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24526       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
24527        real(kind=8),dimension(3,2)::chead,erhead_tail
24528        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24529        integer troll
24530        eps_out=80.0d0
24531        escbase=0.0d0
24532 !       do i=1,nres_molec(1)
24533       do i=ibond_start,ibond_end
24534       if (itype(i,1).eq.ntyp1_molec(1)) cycle
24535       itypi  = itype(i,1)
24536       dxi    = dc_norm(1,nres+i)
24537       dyi    = dc_norm(2,nres+i)
24538       dzi    = dc_norm(3,nres+i)
24539       dsci_inv = vbld_inv(i+nres)
24540       xi=c(1,nres+i)
24541       yi=c(2,nres+i)
24542       zi=c(3,nres+i)
24543       call to_box(xi,yi,zi)
24544       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
24545        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
24546          itypj= itype(j,2)
24547          if (itype(j,2).eq.ntyp1_molec(2))cycle
24548          xj=c(1,j+nres)
24549          yj=c(2,j+nres)
24550          zj=c(3,j+nres)
24551       call to_box(xj,yj,zj)
24552 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
24553 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24554 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24555 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24556 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24557       xj=boxshift(xj-xi,boxxsize)
24558       yj=boxshift(yj-yi,boxysize)
24559       zj=boxshift(zj-zi,boxzsize)
24560
24561         dxj = dc_norm( 1, nres+j )
24562         dyj = dc_norm( 2, nres+j )
24563         dzj = dc_norm( 3, nres+j )
24564 !          print *,i,j,itypi,itypj
24565         d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
24566         d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
24567 !          d1i=0.0d0
24568 !          d1j=0.0d0
24569 !          BetaT = 1.0d0 / (298.0d0 * Rb)
24570 ! Gay-berne var's
24571         sig0ij = sigma_scbase( itypi,itypj )
24572         chi1   = chi_scbase( itypi, itypj,1 )
24573         chi2   = chi_scbase( itypi, itypj,2 )
24574 !          chi1=0.0d0
24575 !          chi2=0.0d0
24576         chi12  = chi1 * chi2
24577         chip1  = chipp_scbase( itypi, itypj,1 )
24578         chip2  = chipp_scbase( itypi, itypj,2 )
24579 !          chip1=0.0d0
24580 !          chip2=0.0d0
24581         chip12 = chip1 * chip2
24582 ! not used by momo potential, but needed by sc_angular which is shared
24583 ! by all energy_potential subroutines
24584         alf1   = 0.0d0
24585         alf2   = 0.0d0
24586         alf12  = 0.0d0
24587         a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
24588 !       a12sq = a12sq * a12sq
24589 ! charge of amino acid itypi is...
24590         chis1 = chis_scbase(itypi,itypj,1)
24591         chis2 = chis_scbase(itypi,itypj,2)
24592         chis12 = chis1 * chis2
24593         sig1 = sigmap1_scbase(itypi,itypj)
24594         sig2 = sigmap2_scbase(itypi,itypj)
24595 !       write (*,*) "sig1 = ", sig1
24596 !       write (*,*) "sig2 = ", sig2
24597 ! alpha factors from Fcav/Gcav
24598         b1 = alphasur_scbase(1,itypi,itypj)
24599 !          b1=0.0d0
24600         b2 = alphasur_scbase(2,itypi,itypj)
24601         b3 = alphasur_scbase(3,itypi,itypj)
24602         b4 = alphasur_scbase(4,itypi,itypj)
24603 ! used to determine whether we want to do quadrupole calculations
24604 ! used by Fgb
24605        eps_in = epsintab_scbase(itypi,itypj)
24606        if (eps_in.eq.0.0) eps_in=1.0
24607        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24608 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24609 !-------------------------------------------------------------------
24610 ! tail location and distance calculations
24611        DO k = 1,3
24612 ! location of polar head is computed by taking hydrophobic centre
24613 ! and moving by a d1 * dc_norm vector
24614 ! see unres publications for very informative images
24615       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
24616       chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
24617 ! distance
24618 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24619 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24620       Rhead_distance(k) = chead(k,2) - chead(k,1)
24621        END DO
24622 ! pitagoras (root of sum of squares)
24623        Rhead = dsqrt( &
24624         (Rhead_distance(1)*Rhead_distance(1)) &
24625       + (Rhead_distance(2)*Rhead_distance(2)) &
24626       + (Rhead_distance(3)*Rhead_distance(3)))
24627 !-------------------------------------------------------------------
24628 ! zero everything that should be zero'ed
24629        evdwij = 0.0d0
24630        ECL = 0.0d0
24631        Elj = 0.0d0
24632        Equad = 0.0d0
24633        Epol = 0.0d0
24634        Fcav=0.0d0
24635        eheadtail = 0.0d0
24636        dGCLdOM1 = 0.0d0
24637        dGCLdOM2 = 0.0d0
24638        dGCLdOM12 = 0.0d0
24639        dPOLdOM1 = 0.0d0
24640        dPOLdOM2 = 0.0d0
24641         Fcav = 0.0d0
24642         dFdR = 0.0d0
24643         dCAVdOM1  = 0.0d0
24644         dCAVdOM2  = 0.0d0
24645         dCAVdOM12 = 0.0d0
24646         dscj_inv = vbld_inv(j+nres)
24647 !          print *,i,j,dscj_inv,dsci_inv
24648 ! rij holds 1/(distance of Calpha atoms)
24649         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24650         rij  = dsqrt(rrij)
24651 !----------------------------
24652         CALL sc_angular
24653 ! this should be in elgrad_init but om's are calculated by sc_angular
24654 ! which in turn is used by older potentials
24655 ! om = omega, sqom = om^2
24656         sqom1  = om1 * om1
24657         sqom2  = om2 * om2
24658         sqom12 = om12 * om12
24659
24660 ! now we calculate EGB - Gey-Berne
24661 ! It will be summed up in evdwij and saved in evdw
24662         sigsq     = 1.0D0  / sigsq
24663         sig       = sig0ij * dsqrt(sigsq)
24664 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24665         rij_shift = 1.0/rij - sig + sig0ij
24666         IF (rij_shift.le.0.0D0) THEN
24667          evdw = 1.0D20
24668          RETURN
24669         END IF
24670         sigder = -sig * sigsq
24671         rij_shift = 1.0D0 / rij_shift
24672         fac       = rij_shift**expon
24673         c1        = fac  * fac * aa_scbase(itypi,itypj)
24674 !          c1        = 0.0d0
24675         c2        = fac  * bb_scbase(itypi,itypj)
24676 !          c2        = 0.0d0
24677         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24678         eps2der   = eps3rt * evdwij
24679         eps3der   = eps2rt * evdwij
24680 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24681         evdwij    = eps2rt * eps3rt * evdwij
24682         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24683         fac    = -expon * (c1 + evdwij) * rij_shift
24684         sigder = fac * sigder
24685 !          fac    = rij * fac
24686 ! Calculate distance derivative
24687         gg(1) =  fac
24688         gg(2) =  fac
24689         gg(3) =  fac
24690 !          if (b2.gt.0.0) then
24691         fac = chis1 * sqom1 + chis2 * sqom2 &
24692         - 2.0d0 * chis12 * om1 * om2 * om12
24693 ! we will use pom later in Gcav, so dont mess with it!
24694         pom = 1.0d0 - chis1 * chis2 * sqom12
24695         Lambf = (1.0d0 - (fac / pom))
24696         Lambf = dsqrt(Lambf)
24697         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24698 !       write (*,*) "sparrow = ", sparrow
24699         Chif = 1.0d0/rij * sparrow
24700         ChiLambf = Chif * Lambf
24701         eagle = dsqrt(ChiLambf)
24702         bat = ChiLambf ** 11.0d0
24703         top = b1 * ( eagle + b2 * ChiLambf - b3 )
24704         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24705         botsq = bot * bot
24706         Fcav = top / bot
24707 !          print *,i,j,Fcav
24708         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24709         dbot = 12.0d0 * b4 * bat * Lambf
24710         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24711 !       dFdR = 0.0d0
24712 !      write (*,*) "dFcav/dR = ", dFdR
24713         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24714         dbot = 12.0d0 * b4 * bat * Chif
24715         eagle = Lambf * pom
24716         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24717         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24718         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24719             * (chis2 * om2 * om12 - om1) / (eagle * pom)
24720
24721         dFdL = ((dtop * bot - top * dbot) / botsq)
24722 !       dFdL = 0.0d0
24723         dCAVdOM1  = dFdL * ( dFdOM1 )
24724         dCAVdOM2  = dFdL * ( dFdOM2 )
24725         dCAVdOM12 = dFdL * ( dFdOM12 )
24726
24727         ertail(1) = xj*rij
24728         ertail(2) = yj*rij
24729         ertail(3) = zj*rij
24730 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
24731 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
24732 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
24733 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
24734 !           print *,"EOMY",eom1,eom2,eom12
24735 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
24736 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
24737 ! here dtail=0.0
24738 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
24739 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24740        DO k = 1, 3
24741 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24742 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24743       pom = ertail(k)
24744 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24745       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
24746               - (( dFdR + gg(k) ) * pom)
24747 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24748 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24749 !     &             - ( dFdR * pom )
24750       pom = ertail(k)
24751 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24752       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
24753               + (( dFdR + gg(k) ) * pom)
24754 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24755 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24756 !c!     &             + ( dFdR * pom )
24757
24758       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
24759               - (( dFdR + gg(k) ) * ertail(k))
24760 !c!     &             - ( dFdR * ertail(k))
24761
24762       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
24763               + (( dFdR + gg(k) ) * ertail(k))
24764 !c!     &             + ( dFdR * ertail(k))
24765
24766       gg(k) = 0.0d0
24767 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24768 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24769       END DO
24770
24771 !          else
24772
24773 !          endif
24774 !Now dipole-dipole
24775        if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
24776        w1 = wdipdip_scbase(1,itypi,itypj)
24777        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
24778        w3 = wdipdip_scbase(2,itypi,itypj)
24779 !c!-------------------------------------------------------------------
24780 !c! ECL
24781        fac = (om12 - 3.0d0 * om1 * om2)
24782        c1 = (w1 / (Rhead**3.0d0)) * fac
24783        c2 = (w2 / Rhead ** 6.0d0)  &
24784        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24785        c3= (w3/ Rhead ** 6.0d0)  &
24786        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24787        ECL = c1 - c2 + c3
24788 !c!       write (*,*) "w1 = ", w1
24789 !c!       write (*,*) "w2 = ", w2
24790 !c!       write (*,*) "om1 = ", om1
24791 !c!       write (*,*) "om2 = ", om2
24792 !c!       write (*,*) "om12 = ", om12
24793 !c!       write (*,*) "fac = ", fac
24794 !c!       write (*,*) "c1 = ", c1
24795 !c!       write (*,*) "c2 = ", c2
24796 !c!       write (*,*) "Ecl = ", Ecl
24797 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
24798 !c!       write (*,*) "c2_2 = ",
24799 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24800 !c!-------------------------------------------------------------------
24801 !c! dervative of ECL is GCL...
24802 !c! dECL/dr
24803        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24804        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24805        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24806        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24807        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24808        dGCLdR = c1 - c2 + c3
24809 !c! dECL/dom1
24810        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24811        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24812        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24813        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24814        dGCLdOM1 = c1 - c2 + c3
24815 !c! dECL/dom2
24816        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24817        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24818        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24819        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24820        dGCLdOM2 = c1 - c2 + c3
24821 !c! dECL/dom12
24822        c1 = w1 / (Rhead ** 3.0d0)
24823        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24824        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24825        dGCLdOM12 = c1 - c2 + c3
24826        DO k= 1, 3
24827       erhead(k) = Rhead_distance(k)/Rhead
24828        END DO
24829        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24830        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24831        facd1 = d1i * vbld_inv(i+nres)
24832        facd2 = d1j * vbld_inv(j+nres)
24833        DO k = 1, 3
24834
24835       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24836       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
24837               - dGCLdR * pom
24838       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24839       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
24840               + dGCLdR * pom
24841
24842       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
24843               - dGCLdR * erhead(k)
24844       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
24845               + dGCLdR * erhead(k)
24846        END DO
24847        endif
24848 !now charge with dipole eg. ARG-dG
24849        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
24850       alphapol1 = alphapol_scbase(itypi,itypj)
24851        w1        = wqdip_scbase(1,itypi,itypj)
24852        w2        = wqdip_scbase(2,itypi,itypj)
24853 !       w1=0.0d0
24854 !       w2=0.0d0
24855 !       pis       = sig0head_scbase(itypi,itypj)
24856 !       eps_head   = epshead_scbase(itypi,itypj)
24857 !c!-------------------------------------------------------------------
24858 !c! R1 - distance between head of ith side chain and tail of jth sidechain
24859        R1 = 0.0d0
24860        DO k = 1, 3
24861 !c! Calculate head-to-tail distances tail is center of side-chain
24862       R1=R1+(c(k,j+nres)-chead(k,1))**2
24863        END DO
24864 !c! Pitagoras
24865        R1 = dsqrt(R1)
24866
24867 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24868 !c!     &        +dhead(1,1,itypi,itypj))**2))
24869 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24870 !c!     &        +dhead(2,1,itypi,itypj))**2))
24871
24872 !c!-------------------------------------------------------------------
24873 !c! ecl
24874        sparrow  = w1  *  om1
24875        hawk     = w2 *  (1.0d0 - sqom2)
24876        Ecl = sparrow / Rhead**2.0d0 &
24877          - hawk    / Rhead**4.0d0
24878 !c!-------------------------------------------------------------------
24879 !c! derivative of ecl is Gcl
24880 !c! dF/dr part
24881        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24882             + 4.0d0 * hawk    / Rhead**5.0d0
24883 !c! dF/dom1
24884        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24885 !c! dF/dom2
24886        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24887 !c--------------------------------------------------------------------
24888 !c Polarization energy
24889 !c Epol
24890        MomoFac1 = (1.0d0 - chi1 * sqom2)
24891        RR1  = R1 * R1 / MomoFac1
24892        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24893        fgb1 = sqrt( RR1 + a12sq * ee1)
24894 !       eps_inout_fac=0.0d0
24895        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
24896 ! derivative of Epol is Gpol...
24897        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
24898             / (fgb1 ** 5.0d0)
24899        dFGBdR1 = ( (R1 / MomoFac1) &
24900            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
24901            / ( 2.0d0 * fgb1 )
24902        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24903              * (2.0d0 - 0.5d0 * ee1) ) &
24904              / (2.0d0 * fgb1)
24905        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24906 !       dPOLdR1 = 0.0d0
24907        dPOLdOM1 = 0.0d0
24908        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
24909        DO k = 1, 3
24910       erhead(k) = Rhead_distance(k)/Rhead
24911       erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
24912        END DO
24913
24914        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24915        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24916        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24917 !       bat=0.0d0
24918        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
24919        facd1 = d1i * vbld_inv(i+nres)
24920        facd2 = d1j * vbld_inv(j+nres)
24921 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24922
24923        DO k = 1, 3
24924       hawk = (erhead_tail(k,1) + &
24925       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
24926 !        facd1=0.0d0
24927 !        facd2=0.0d0
24928       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24929       gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
24930                - dGCLdR * pom &
24931                - dPOLdR1 *  (erhead_tail(k,1))
24932 !     &             - dGLJdR * pom
24933
24934       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24935       gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
24936                + dGCLdR * pom  &
24937                + dPOLdR1 * (erhead_tail(k,1))
24938 !     &             + dGLJdR * pom
24939
24940
24941       gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
24942               - dGCLdR * erhead(k) &
24943               - dPOLdR1 * erhead_tail(k,1)
24944 !     &             - dGLJdR * erhead(k)
24945
24946       gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
24947               + dGCLdR * erhead(k)  &
24948               + dPOLdR1 * erhead_tail(k,1)
24949 !     &             + dGLJdR * erhead(k)
24950
24951        END DO
24952        endif
24953 !       print *,i,j,evdwij,epol,Fcav,ECL
24954        escbase=escbase+evdwij+epol+Fcav+ECL
24955        call sc_grad_scbase
24956        enddo
24957       enddo
24958
24959       return
24960       end subroutine eprot_sc_base
24961       SUBROUTINE sc_grad_scbase
24962       use calc_data
24963
24964        real (kind=8) :: dcosom1(3),dcosom2(3)
24965        eom1  =    &
24966             eps2der * eps2rt_om1   &
24967           - 2.0D0 * alf1 * eps3der &
24968           + sigder * sigsq_om1     &
24969           + dCAVdOM1               &
24970           + dGCLdOM1               &
24971           + dPOLdOM1
24972
24973        eom2  =  &
24974             eps2der * eps2rt_om2   &
24975           + 2.0D0 * alf2 * eps3der &
24976           + sigder * sigsq_om2     &
24977           + dCAVdOM2               &
24978           + dGCLdOM2               &
24979           + dPOLdOM2
24980
24981        eom12 =    &
24982             evdwij  * eps1_om12     &
24983           + eps2der * eps2rt_om12   &
24984           - 2.0D0 * alf12 * eps3der &
24985           + sigder *sigsq_om12      &
24986           + dCAVdOM12               &
24987           + dGCLdOM12
24988
24989 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24990 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24991 !               gg(1),gg(2),"rozne"
24992        DO k = 1, 3
24993       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24994       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24995       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24996       gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
24997              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24998              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24999       gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
25000              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25001              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25002       gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
25003       gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
25004        END DO
25005        RETURN
25006       END SUBROUTINE sc_grad_scbase
25007
25008
25009       subroutine epep_sc_base(epepbase)
25010       use calc_data
25011       logical :: lprn
25012 !el local variables
25013       integer :: iint,itypi,itypi1,itypj,subchap
25014       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25015       real(kind=8) :: evdw,sig0ij
25016       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25017                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25018                 sslipi,sslipj,faclip
25019       integer :: ii
25020       real(kind=8) :: fracinbuf
25021        real (kind=8) :: epepbase
25022        real (kind=8),dimension(4):: ener
25023        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25024        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25025       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
25026       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25027       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
25028       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25029       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25030       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
25031        real(kind=8),dimension(3,2)::chead,erhead_tail
25032        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25033        integer troll
25034        eps_out=80.0d0
25035        epepbase=0.0d0
25036 !       do i=1,nres_molec(1)-1
25037       do i=ibond_start,ibond_end
25038       if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
25039 !C        itypi  = itype(i,1)
25040       dxi    = dc_norm(1,i)
25041       dyi    = dc_norm(2,i)
25042       dzi    = dc_norm(3,i)
25043 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
25044       dsci_inv = vbld_inv(i+1)/2.0
25045       xi=(c(1,i)+c(1,i+1))/2.0
25046       yi=(c(2,i)+c(2,i+1))/2.0
25047       zi=(c(3,i)+c(3,i+1))/2.0
25048         call to_box(xi,yi,zi)
25049        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
25050          itypj= itype(j,2)
25051          if (itype(j,2).eq.ntyp1_molec(2))cycle
25052          xj=c(1,j+nres)
25053          yj=c(2,j+nres)
25054          zj=c(3,j+nres)
25055                 call to_box(xj,yj,zj)
25056       xj=boxshift(xj-xi,boxxsize)
25057       yj=boxshift(yj-yi,boxysize)
25058       zj=boxshift(zj-zi,boxzsize)
25059         dist_init=xj**2+yj**2+zj**2
25060         dxj = dc_norm( 1, nres+j )
25061         dyj = dc_norm( 2, nres+j )
25062         dzj = dc_norm( 3, nres+j )
25063 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
25064 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
25065
25066 ! Gay-berne var's
25067         sig0ij = sigma_pepbase(itypj )
25068         chi1   = chi_pepbase(itypj,1 )
25069         chi2   = chi_pepbase(itypj,2 )
25070 !          chi1=0.0d0
25071 !          chi2=0.0d0
25072         chi12  = chi1 * chi2
25073         chip1  = chipp_pepbase(itypj,1 )
25074         chip2  = chipp_pepbase(itypj,2 )
25075 !          chip1=0.0d0
25076 !          chip2=0.0d0
25077         chip12 = chip1 * chip2
25078         chis1 = chis_pepbase(itypj,1)
25079         chis2 = chis_pepbase(itypj,2)
25080         chis12 = chis1 * chis2
25081         sig1 = sigmap1_pepbase(itypj)
25082         sig2 = sigmap2_pepbase(itypj)
25083 !       write (*,*) "sig1 = ", sig1
25084 !       write (*,*) "sig2 = ", sig2
25085        DO k = 1,3
25086 ! location of polar head is computed by taking hydrophobic centre
25087 ! and moving by a d1 * dc_norm vector
25088 ! see unres publications for very informative images
25089       chead(k,1) = (c(k,i)+c(k,i+1))/2.0
25090 ! + d1i * dc_norm(k, i+nres)
25091       chead(k,2) = c(k, j+nres)
25092 ! + d1j * dc_norm(k, j+nres)
25093 ! distance
25094 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25095 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25096       Rhead_distance(k) = chead(k,2) - chead(k,1)
25097 !        print *,gvdwc_pepbase(k,i)
25098
25099        END DO
25100        Rhead = dsqrt( &
25101         (Rhead_distance(1)*Rhead_distance(1)) &
25102       + (Rhead_distance(2)*Rhead_distance(2)) &
25103       + (Rhead_distance(3)*Rhead_distance(3)))
25104
25105 ! alpha factors from Fcav/Gcav
25106         b1 = alphasur_pepbase(1,itypj)
25107 !          b1=0.0d0
25108         b2 = alphasur_pepbase(2,itypj)
25109         b3 = alphasur_pepbase(3,itypj)
25110         b4 = alphasur_pepbase(4,itypj)
25111         alf1   = 0.0d0
25112         alf2   = 0.0d0
25113         alf12  = 0.0d0
25114         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25115 !          print *,i,j,rrij
25116         rij  = dsqrt(rrij)
25117 !----------------------------
25118        evdwij = 0.0d0
25119        ECL = 0.0d0
25120        Elj = 0.0d0
25121        Equad = 0.0d0
25122        Epol = 0.0d0
25123        Fcav=0.0d0
25124        eheadtail = 0.0d0
25125        dGCLdOM1 = 0.0d0
25126        dGCLdOM2 = 0.0d0
25127        dGCLdOM12 = 0.0d0
25128        dPOLdOM1 = 0.0d0
25129        dPOLdOM2 = 0.0d0
25130         Fcav = 0.0d0
25131         dFdR = 0.0d0
25132         dCAVdOM1  = 0.0d0
25133         dCAVdOM2  = 0.0d0
25134         dCAVdOM12 = 0.0d0
25135         dscj_inv = vbld_inv(j+nres)
25136         CALL sc_angular
25137 ! this should be in elgrad_init but om's are calculated by sc_angular
25138 ! which in turn is used by older potentials
25139 ! om = omega, sqom = om^2
25140         sqom1  = om1 * om1
25141         sqom2  = om2 * om2
25142         sqom12 = om12 * om12
25143
25144 ! now we calculate EGB - Gey-Berne
25145 ! It will be summed up in evdwij and saved in evdw
25146         sigsq     = 1.0D0  / sigsq
25147         sig       = sig0ij * dsqrt(sigsq)
25148         rij_shift = 1.0/rij - sig + sig0ij
25149         IF (rij_shift.le.0.0D0) THEN
25150          evdw = 1.0D20
25151          RETURN
25152         END IF
25153         sigder = -sig * sigsq
25154         rij_shift = 1.0D0 / rij_shift
25155         fac       = rij_shift**expon
25156         c1        = fac  * fac * aa_pepbase(itypj)
25157 !          c1        = 0.0d0
25158         c2        = fac  * bb_pepbase(itypj)
25159 !          c2        = 0.0d0
25160         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25161         eps2der   = eps3rt * evdwij
25162         eps3der   = eps2rt * evdwij
25163 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25164         evdwij    = eps2rt * eps3rt * evdwij
25165         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25166         fac    = -expon * (c1 + evdwij) * rij_shift
25167         sigder = fac * sigder
25168 !          fac    = rij * fac
25169 ! Calculate distance derivative
25170         gg(1) =  fac
25171         gg(2) =  fac
25172         gg(3) =  fac
25173         fac = chis1 * sqom1 + chis2 * sqom2 &
25174         - 2.0d0 * chis12 * om1 * om2 * om12
25175 ! we will use pom later in Gcav, so dont mess with it!
25176         pom = 1.0d0 - chis1 * chis2 * sqom12
25177         Lambf = (1.0d0 - (fac / pom))
25178         Lambf = dsqrt(Lambf)
25179         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25180 !       write (*,*) "sparrow = ", sparrow
25181         Chif = 1.0d0/rij * sparrow
25182         ChiLambf = Chif * Lambf
25183         eagle = dsqrt(ChiLambf)
25184         bat = ChiLambf ** 11.0d0
25185         top = b1 * ( eagle + b2 * ChiLambf - b3 )
25186         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
25187         botsq = bot * bot
25188         Fcav = top / bot
25189 !          print *,i,j,Fcav
25190         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
25191         dbot = 12.0d0 * b4 * bat * Lambf
25192         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25193 !       dFdR = 0.0d0
25194 !      write (*,*) "dFcav/dR = ", dFdR
25195         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
25196         dbot = 12.0d0 * b4 * bat * Chif
25197         eagle = Lambf * pom
25198         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25199         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25200         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25201             * (chis2 * om2 * om12 - om1) / (eagle * pom)
25202
25203         dFdL = ((dtop * bot - top * dbot) / botsq)
25204 !       dFdL = 0.0d0
25205         dCAVdOM1  = dFdL * ( dFdOM1 )
25206         dCAVdOM2  = dFdL * ( dFdOM2 )
25207         dCAVdOM12 = dFdL * ( dFdOM12 )
25208
25209         ertail(1) = xj*rij
25210         ertail(2) = yj*rij
25211         ertail(3) = zj*rij
25212        DO k = 1, 3
25213 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25214 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25215       pom = ertail(k)
25216 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25217       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
25218               - (( dFdR + gg(k) ) * pom)/2.0
25219 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
25220 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
25221 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25222 !     &             - ( dFdR * pom )
25223       pom = ertail(k)
25224 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25225       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
25226               + (( dFdR + gg(k) ) * pom)
25227 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25228 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25229 !c!     &             + ( dFdR * pom )
25230
25231       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
25232               - (( dFdR + gg(k) ) * ertail(k))/2.0
25233 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
25234
25235 !c!     &             - ( dFdR * ertail(k))
25236
25237       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
25238               + (( dFdR + gg(k) ) * ertail(k))
25239 !c!     &             + ( dFdR * ertail(k))
25240
25241       gg(k) = 0.0d0
25242 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25243 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25244       END DO
25245
25246
25247        w1 = wdipdip_pepbase(1,itypj)
25248        w2 = -wdipdip_pepbase(3,itypj)/2.0
25249        w3 = wdipdip_pepbase(2,itypj)
25250 !       w1=0.0d0
25251 !       w2=0.0d0
25252 !c!-------------------------------------------------------------------
25253 !c! ECL
25254 !       w3=0.0d0
25255        fac = (om12 - 3.0d0 * om1 * om2)
25256        c1 = (w1 / (Rhead**3.0d0)) * fac
25257        c2 = (w2 / Rhead ** 6.0d0)  &
25258        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
25259        c3= (w3/ Rhead ** 6.0d0)  &
25260        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
25261
25262        ECL = c1 - c2 + c3
25263
25264        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
25265        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
25266        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
25267        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
25268        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
25269
25270        dGCLdR = c1 - c2 + c3
25271 !c! dECL/dom1
25272        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
25273        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25274        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
25275        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
25276        dGCLdOM1 = c1 - c2 + c3
25277 !c! dECL/dom2
25278        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
25279        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25280        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
25281        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
25282
25283        dGCLdOM2 = c1 - c2 + c3
25284 !c! dECL/dom12
25285        c1 = w1 / (Rhead ** 3.0d0)
25286        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
25287        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
25288        dGCLdOM12 = c1 - c2 + c3
25289        DO k= 1, 3
25290       erhead(k) = Rhead_distance(k)/Rhead
25291        END DO
25292        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25293        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25294 !       facd1 = d1 * vbld_inv(i+nres)
25295 !       facd2 = d2 * vbld_inv(j+nres)
25296        DO k = 1, 3
25297
25298 !        pom = erhead(k)
25299 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25300 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
25301 !                  - dGCLdR * pom
25302       pom = erhead(k)
25303 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25304       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
25305               + dGCLdR * pom
25306
25307       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
25308               - dGCLdR * erhead(k)/2.0d0
25309 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
25310       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
25311               - dGCLdR * erhead(k)/2.0d0
25312 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
25313       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
25314               + dGCLdR * erhead(k)
25315        END DO
25316 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
25317        epepbase=epepbase+evdwij+Fcav+ECL
25318        call sc_grad_pepbase
25319        enddo
25320        enddo
25321       END SUBROUTINE epep_sc_base
25322       SUBROUTINE sc_grad_pepbase
25323       use calc_data
25324
25325        real (kind=8) :: dcosom1(3),dcosom2(3)
25326        eom1  =    &
25327             eps2der * eps2rt_om1   &
25328           - 2.0D0 * alf1 * eps3der &
25329           + sigder * sigsq_om1     &
25330           + dCAVdOM1               &
25331           + dGCLdOM1               &
25332           + dPOLdOM1
25333
25334        eom2  =  &
25335             eps2der * eps2rt_om2   &
25336           + 2.0D0 * alf2 * eps3der &
25337           + sigder * sigsq_om2     &
25338           + dCAVdOM2               &
25339           + dGCLdOM2               &
25340           + dPOLdOM2
25341
25342        eom12 =    &
25343             evdwij  * eps1_om12     &
25344           + eps2der * eps2rt_om12   &
25345           - 2.0D0 * alf12 * eps3der &
25346           + sigder *sigsq_om12      &
25347           + dCAVdOM12               &
25348           + dGCLdOM12
25349 !        om12=0.0
25350 !        eom12=0.0
25351 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
25352 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
25353 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25354 !                 *dsci_inv*2.0
25355 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
25356 !               gg(1),gg(2),"rozne"
25357        DO k = 1, 3
25358       dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
25359       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25360       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25361       gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
25362              + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25363              *dsci_inv*2.0 &
25364              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25365       gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
25366              - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
25367              *dsci_inv*2.0 &
25368              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25369 !         print *,eom12,eom2,om12,om2
25370 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
25371 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
25372       gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
25373              + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
25374              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25375       gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
25376        END DO
25377        RETURN
25378       END SUBROUTINE sc_grad_pepbase
25379       subroutine eprot_sc_phosphate(escpho)
25380       use calc_data
25381 !      implicit real*8 (a-h,o-z)
25382 !      include 'DIMENSIONS'
25383 !      include 'COMMON.GEO'
25384 !      include 'COMMON.VAR'
25385 !      include 'COMMON.LOCAL'
25386 !      include 'COMMON.CHAIN'
25387 !      include 'COMMON.DERIV'
25388 !      include 'COMMON.NAMES'
25389 !      include 'COMMON.INTERACT'
25390 !      include 'COMMON.IOUNITS'
25391 !      include 'COMMON.CALC'
25392 !      include 'COMMON.CONTROL'
25393 !      include 'COMMON.SBRIDGE'
25394       logical :: lprn
25395 !el local variables
25396       integer :: iint,itypi,itypi1,itypj,subchap
25397       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25398       real(kind=8) :: evdw,sig0ij,aa,bb
25399       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25400                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
25401                 sslipi,sslipj,faclip,alpha_sco
25402       integer :: ii
25403       real(kind=8) :: fracinbuf
25404        real (kind=8) :: escpho
25405        real (kind=8),dimension(4):: ener
25406        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25407        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25408       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
25409       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25410       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
25411       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25412       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25413       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
25414        real(kind=8),dimension(3,2)::chead,erhead_tail
25415        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25416        integer troll
25417        eps_out=80.0d0
25418        escpho=0.0d0
25419 !       do i=1,nres_molec(1)
25420       do i=ibond_start,ibond_end
25421       if (itype(i,1).eq.ntyp1_molec(1)) cycle
25422       itypi  = itype(i,1)
25423       dxi    = dc_norm(1,nres+i)
25424       dyi    = dc_norm(2,nres+i)
25425       dzi    = dc_norm(3,nres+i)
25426       dsci_inv = vbld_inv(i+nres)
25427       xi=c(1,nres+i)
25428       yi=c(2,nres+i)
25429       zi=c(3,nres+i)
25430        call to_box(xi,yi,zi)
25431       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
25432        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
25433          itypj= itype(j,2)
25434          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
25435           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
25436          xj=(c(1,j)+c(1,j+1))/2.0
25437          yj=(c(2,j)+c(2,j+1))/2.0
25438          zj=(c(3,j)+c(3,j+1))/2.0
25439      call to_box(xj,yj,zj)
25440 !     call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
25441 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25442 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25443 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25444 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25445       xj=boxshift(xj-xi,boxxsize)
25446       yj=boxshift(yj-yi,boxysize)
25447       zj=boxshift(zj-zi,boxzsize)
25448           dxj = dc_norm( 1,j )
25449         dyj = dc_norm( 2,j )
25450         dzj = dc_norm( 3,j )
25451         dscj_inv = vbld_inv(j+1)
25452
25453 ! Gay-berne var's
25454         sig0ij = sigma_scpho(itypi )
25455         chi1   = chi_scpho(itypi,1 )
25456         chi2   = chi_scpho(itypi,2 )
25457 !          chi1=0.0d0
25458 !          chi2=0.0d0
25459         chi12  = chi1 * chi2
25460         chip1  = chipp_scpho(itypi,1 )
25461         chip2  = chipp_scpho(itypi,2 )
25462 !          chip1=0.0d0
25463 !          chip2=0.0d0
25464         chip12 = chip1 * chip2
25465         chis1 = chis_scpho(itypi,1)
25466         chis2 = chis_scpho(itypi,2)
25467         chis12 = chis1 * chis2
25468         sig1 = sigmap1_scpho(itypi)
25469         sig2 = sigmap2_scpho(itypi)
25470 !       write (*,*) "sig1 = ", sig1
25471 !       write (*,*) "sig1 = ", sig1
25472 !       write (*,*) "sig2 = ", sig2
25473 ! alpha factors from Fcav/Gcav
25474         alf1   = 0.0d0
25475         alf2   = 0.0d0
25476         alf12  = 0.0d0
25477         a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
25478
25479         b1 = alphasur_scpho(1,itypi)
25480 !          b1=0.0d0
25481         b2 = alphasur_scpho(2,itypi)
25482         b3 = alphasur_scpho(3,itypi)
25483         b4 = alphasur_scpho(4,itypi)
25484 ! used to determine whether we want to do quadrupole calculations
25485 ! used by Fgb
25486        eps_in = epsintab_scpho(itypi)
25487        if (eps_in.eq.0.0) eps_in=1.0
25488        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25489 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
25490 !-------------------------------------------------------------------
25491 ! tail location and distance calculations
25492         d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
25493         d1j = 0.0
25494        DO k = 1,3
25495 ! location of polar head is computed by taking hydrophobic centre
25496 ! and moving by a d1 * dc_norm vector
25497 ! see unres publications for very informative images
25498       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
25499       chead(k,2) = (c(k, j) + c(k, j+1))/2.0
25500 ! distance
25501 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25502 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25503       Rhead_distance(k) = chead(k,2) - chead(k,1)
25504        END DO
25505 ! pitagoras (root of sum of squares)
25506        Rhead = dsqrt( &
25507         (Rhead_distance(1)*Rhead_distance(1)) &
25508       + (Rhead_distance(2)*Rhead_distance(2)) &
25509       + (Rhead_distance(3)*Rhead_distance(3)))
25510        Rhead_sq=Rhead**2.0
25511 !-------------------------------------------------------------------
25512 ! zero everything that should be zero'ed
25513        evdwij = 0.0d0
25514        ECL = 0.0d0
25515        Elj = 0.0d0
25516        Equad = 0.0d0
25517        Epol = 0.0d0
25518        Fcav=0.0d0
25519        eheadtail = 0.0d0
25520        dGCLdR=0.0d0
25521        dGCLdOM1 = 0.0d0
25522        dGCLdOM2 = 0.0d0
25523        dGCLdOM12 = 0.0d0
25524        dPOLdOM1 = 0.0d0
25525        dPOLdOM2 = 0.0d0
25526         Fcav = 0.0d0
25527         dFdR = 0.0d0
25528         dCAVdOM1  = 0.0d0
25529         dCAVdOM2  = 0.0d0
25530         dCAVdOM12 = 0.0d0
25531         dscj_inv = vbld_inv(j+1)/2.0
25532 !dhead_scbasej(itypi,itypj)
25533 !          print *,i,j,dscj_inv,dsci_inv
25534 ! rij holds 1/(distance of Calpha atoms)
25535         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25536         rij  = dsqrt(rrij)
25537 !----------------------------
25538         CALL sc_angular
25539 ! this should be in elgrad_init but om's are calculated by sc_angular
25540 ! which in turn is used by older potentials
25541 ! om = omega, sqom = om^2
25542         sqom1  = om1 * om1
25543         sqom2  = om2 * om2
25544         sqom12 = om12 * om12
25545
25546 ! now we calculate EGB - Gey-Berne
25547 ! It will be summed up in evdwij and saved in evdw
25548         sigsq     = 1.0D0  / sigsq
25549         sig       = sig0ij * dsqrt(sigsq)
25550 !          rij_shift = 1.0D0  / rij - sig + sig0ij
25551         rij_shift = 1.0/rij - sig + sig0ij
25552         IF (rij_shift.le.0.0D0) THEN
25553          evdw = 1.0D20
25554          RETURN
25555         END IF
25556         sigder = -sig * sigsq
25557         rij_shift = 1.0D0 / rij_shift
25558         fac       = rij_shift**expon
25559         c1        = fac  * fac * aa_scpho(itypi)
25560 !          c1        = 0.0d0
25561         c2        = fac  * bb_scpho(itypi)
25562 !          c2        = 0.0d0
25563         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25564         eps2der   = eps3rt * evdwij
25565         eps3der   = eps2rt * evdwij
25566 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25567         evdwij    = eps2rt * eps3rt * evdwij
25568         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25569         fac    = -expon * (c1 + evdwij) * rij_shift
25570         sigder = fac * sigder
25571 !          fac    = rij * fac
25572 ! Calculate distance derivative
25573         gg(1) =  fac
25574         gg(2) =  fac
25575         gg(3) =  fac
25576         fac = chis1 * sqom1 + chis2 * sqom2 &
25577         - 2.0d0 * chis12 * om1 * om2 * om12
25578 ! we will use pom later in Gcav, so dont mess with it!
25579         pom = 1.0d0 - chis1 * chis2 * sqom12
25580         Lambf = (1.0d0 - (fac / pom))
25581         Lambf = dsqrt(Lambf)
25582         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25583 !       write (*,*) "sparrow = ", sparrow
25584         Chif = 1.0d0/rij * sparrow
25585         ChiLambf = Chif * Lambf
25586         eagle = dsqrt(ChiLambf)
25587         bat = ChiLambf ** 11.0d0
25588         top = b1 * ( eagle + b2 * ChiLambf - b3 )
25589         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
25590         botsq = bot * bot
25591         Fcav = top / bot
25592         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
25593         dbot = 12.0d0 * b4 * bat * Lambf
25594         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25595 !       dFdR = 0.0d0
25596 !      write (*,*) "dFcav/dR = ", dFdR
25597         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
25598         dbot = 12.0d0 * b4 * bat * Chif
25599         eagle = Lambf * pom
25600         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25601         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25602         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25603             * (chis2 * om2 * om12 - om1) / (eagle * pom)
25604
25605         dFdL = ((dtop * bot - top * dbot) / botsq)
25606 !       dFdL = 0.0d0
25607         dCAVdOM1  = dFdL * ( dFdOM1 )
25608         dCAVdOM2  = dFdL * ( dFdOM2 )
25609         dCAVdOM12 = dFdL * ( dFdOM12 )
25610
25611         ertail(1) = xj*rij
25612         ertail(2) = yj*rij
25613         ertail(3) = zj*rij
25614        DO k = 1, 3
25615 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25616 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25617 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
25618
25619       pom = ertail(k)
25620 !        print *,pom,gg(k),dFdR
25621 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25622       gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
25623               - (( dFdR + gg(k) ) * pom)
25624 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
25625 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25626 !     &             - ( dFdR * pom )
25627 !        pom = ertail(k)
25628 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25629 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
25630 !                  + (( dFdR + gg(k) ) * pom)
25631 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25632 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25633 !c!     &             + ( dFdR * pom )
25634
25635       gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
25636               - (( dFdR + gg(k) ) * ertail(k))
25637 !c!     &             - ( dFdR * ertail(k))
25638
25639       gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
25640               + (( dFdR + gg(k) ) * ertail(k))/2.0
25641
25642       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
25643               + (( dFdR + gg(k) ) * ertail(k))/2.0
25644
25645 !c!     &             + ( dFdR * ertail(k))
25646
25647       gg(k) = 0.0d0
25648       ENDDO
25649 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25650 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25651 !      alphapol1 = alphapol_scpho(itypi)
25652        if (wqq_scpho(itypi).ne.0.0) then
25653        Qij=wqq_scpho(itypi)/eps_in
25654        alpha_sco=1.d0/alphi_scpho(itypi)
25655 !       Qij=0.0
25656        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
25657 !c! derivative of Ecl is Gcl...
25658        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
25659             (Rhead*alpha_sco+1) ) / Rhead_sq
25660        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
25661        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
25662        w1        = wqdip_scpho(1,itypi)
25663        w2        = wqdip_scpho(2,itypi)
25664 !       w1=0.0d0
25665 !       w2=0.0d0
25666 !       pis       = sig0head_scbase(itypi,itypj)
25667 !       eps_head   = epshead_scbase(itypi,itypj)
25668 !c!-------------------------------------------------------------------
25669
25670 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25671 !c!     &        +dhead(1,1,itypi,itypj))**2))
25672 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25673 !c!     &        +dhead(2,1,itypi,itypj))**2))
25674
25675 !c!-------------------------------------------------------------------
25676 !c! ecl
25677        sparrow  = w1  *  om1
25678        hawk     = w2 *  (1.0d0 - sqom2)
25679        Ecl = sparrow / Rhead**2.0d0 &
25680          - hawk    / Rhead**4.0d0
25681 !c!-------------------------------------------------------------------
25682        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
25683          1.0/rij,sparrow
25684
25685 !c! derivative of ecl is Gcl
25686 !c! dF/dr part
25687        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
25688             + 4.0d0 * hawk    / Rhead**5.0d0
25689 !c! dF/dom1
25690        dGCLdOM1 = (w1) / (Rhead**2.0d0)
25691 !c! dF/dom2
25692        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
25693        endif
25694
25695 !c--------------------------------------------------------------------
25696 !c Polarization energy
25697 !c Epol
25698        R1 = 0.0d0
25699        DO k = 1, 3
25700 !c! Calculate head-to-tail distances tail is center of side-chain
25701       R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
25702        END DO
25703 !c! Pitagoras
25704        R1 = dsqrt(R1)
25705
25706       alphapol1 = alphapol_scpho(itypi)
25707 !      alphapol1=0.0
25708        MomoFac1 = (1.0d0 - chi2 * sqom1)
25709        RR1  = R1 * R1 / MomoFac1
25710        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25711 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
25712        fgb1 = sqrt( RR1 + a12sq * ee1)
25713 !       eps_inout_fac=0.0d0
25714        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
25715 ! derivative of Epol is Gpol...
25716        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
25717             / (fgb1 ** 5.0d0)
25718        dFGBdR1 = ( (R1 / MomoFac1) &
25719            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
25720            / ( 2.0d0 * fgb1 )
25721        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25722              * (2.0d0 - 0.5d0 * ee1) ) &
25723              / (2.0d0 * fgb1)
25724        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25725 !       dPOLdR1 = 0.0d0
25726 !       dPOLdOM1 = 0.0d0
25727        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
25728              * (2.0d0 - 0.5d0 * ee1) ) &
25729              / (2.0d0 * fgb1)
25730
25731        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
25732        dPOLdOM2 = 0.0
25733        DO k = 1, 3
25734       erhead(k) = Rhead_distance(k)/Rhead
25735       erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
25736        END DO
25737
25738        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25739        erdxj = scalar( erhead(1), dC_norm(1,j) )
25740        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25741 !       bat=0.0d0
25742        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
25743        facd1 = d1i * vbld_inv(i+nres)
25744        facd2 = d1j * vbld_inv(j)
25745 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25746
25747        DO k = 1, 3
25748       hawk = (erhead_tail(k,1) + &
25749       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
25750 !        facd1=0.0d0
25751 !        facd2=0.0d0
25752 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
25753 !                pom,(erhead_tail(k,1))
25754
25755 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
25756       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25757       gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
25758                - dGCLdR * pom &
25759                - dPOLdR1 *  (erhead_tail(k,1))
25760 !     &             - dGLJdR * pom
25761
25762       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
25763 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
25764 !                   + dGCLdR * pom  &
25765 !                   + dPOLdR1 * (erhead_tail(k,1))
25766 !     &             + dGLJdR * pom
25767
25768
25769       gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
25770               - dGCLdR * erhead(k) &
25771               - dPOLdR1 * erhead_tail(k,1)
25772 !     &             - dGLJdR * erhead(k)
25773
25774       gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
25775               + (dGCLdR * erhead(k)  &
25776               + dPOLdR1 * erhead_tail(k,1))/2.0
25777       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
25778               + (dGCLdR * erhead(k)  &
25779               + dPOLdR1 * erhead_tail(k,1))/2.0
25780
25781 !     &             + dGLJdR * erhead(k)
25782 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
25783
25784        END DO
25785 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
25786        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
25787       "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
25788        escpho=escpho+evdwij+epol+Fcav+ECL
25789        call sc_grad_scpho
25790        enddo
25791
25792       enddo
25793
25794       return
25795       end subroutine eprot_sc_phosphate
25796       SUBROUTINE sc_grad_scpho
25797       use calc_data
25798
25799        real (kind=8) :: dcosom1(3),dcosom2(3)
25800        eom1  =    &
25801             eps2der * eps2rt_om1   &
25802           - 2.0D0 * alf1 * eps3der &
25803           + sigder * sigsq_om1     &
25804           + dCAVdOM1               &
25805           + dGCLdOM1               &
25806           + dPOLdOM1
25807
25808        eom2  =  &
25809             eps2der * eps2rt_om2   &
25810           + 2.0D0 * alf2 * eps3der &
25811           + sigder * sigsq_om2     &
25812           + dCAVdOM2               &
25813           + dGCLdOM2               &
25814           + dPOLdOM2
25815
25816        eom12 =    &
25817             evdwij  * eps1_om12     &
25818           + eps2der * eps2rt_om12   &
25819           - 2.0D0 * alf12 * eps3der &
25820           + sigder *sigsq_om12      &
25821           + dCAVdOM12               &
25822           + dGCLdOM12
25823 !        om12=0.0
25824 !        eom12=0.0
25825 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
25826 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
25827 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25828 !                 *dsci_inv*2.0
25829 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
25830 !               gg(1),gg(2),"rozne"
25831        DO k = 1, 3
25832       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25833       dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
25834       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25835       gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
25836              + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
25837              *dscj_inv*2.0 &
25838              - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25839       gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
25840              - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
25841              *dscj_inv*2.0 &
25842              + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25843       gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
25844              + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
25845              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25846
25847 !         print *,eom12,eom2,om12,om2
25848 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
25849 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
25850 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
25851 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
25852 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25853       gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
25854        END DO
25855        RETURN
25856       END SUBROUTINE sc_grad_scpho
25857       subroutine eprot_pep_phosphate(epeppho)
25858       use calc_data
25859 !      implicit real*8 (a-h,o-z)
25860 !      include 'DIMENSIONS'
25861 !      include 'COMMON.GEO'
25862 !      include 'COMMON.VAR'
25863 !      include 'COMMON.LOCAL'
25864 !      include 'COMMON.CHAIN'
25865 !      include 'COMMON.DERIV'
25866 !      include 'COMMON.NAMES'
25867 !      include 'COMMON.INTERACT'
25868 !      include 'COMMON.IOUNITS'
25869 !      include 'COMMON.CALC'
25870 !      include 'COMMON.CONTROL'
25871 !      include 'COMMON.SBRIDGE'
25872       logical :: lprn
25873 !el local variables
25874       integer :: iint,itypi,itypi1,itypj,subchap
25875       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25876       real(kind=8) :: evdw,sig0ij
25877       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25878                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25879                 sslipi,sslipj,faclip
25880       integer :: ii
25881       real(kind=8) :: fracinbuf
25882        real (kind=8) :: epeppho
25883        real (kind=8),dimension(4):: ener
25884        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25885        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25886       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
25887       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25888       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
25889       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25890       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25891       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
25892        real(kind=8),dimension(3,2)::chead,erhead_tail
25893        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25894        integer troll
25895        real (kind=8) :: dcosom1(3),dcosom2(3)
25896        epeppho=0.0d0
25897 !       do i=1,nres_molec(1)
25898       do i=ibond_start,ibond_end
25899       if (itype(i,1).eq.ntyp1_molec(1)) cycle
25900       itypi  = itype(i,1)
25901       dsci_inv = vbld_inv(i+1)/2.0
25902       dxi    = dc_norm(1,i)
25903       dyi    = dc_norm(2,i)
25904       dzi    = dc_norm(3,i)
25905       xi=(c(1,i)+c(1,i+1))/2.0
25906       yi=(c(2,i)+c(2,i+1))/2.0
25907       zi=(c(3,i)+c(3,i+1))/2.0
25908                call to_box(xi,yi,zi)
25909
25910         do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
25911          itypj= itype(j,2)
25912          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
25913           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
25914          xj=(c(1,j)+c(1,j+1))/2.0
25915          yj=(c(2,j)+c(2,j+1))/2.0
25916          zj=(c(3,j)+c(3,j+1))/2.0
25917                 call to_box(xj,yj,zj)
25918       xj=boxshift(xj-xi,boxxsize)
25919       yj=boxshift(yj-yi,boxysize)
25920       zj=boxshift(zj-zi,boxzsize)
25921
25922         dist_init=xj**2+yj**2+zj**2
25923         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25924         rij  = dsqrt(rrij)
25925         dxj = dc_norm( 1,j )
25926         dyj = dc_norm( 2,j )
25927         dzj = dc_norm( 3,j )
25928         dscj_inv = vbld_inv(j+1)/2.0
25929 ! Gay-berne var's
25930         sig0ij = sigma_peppho
25931 !          chi1=0.0d0
25932 !          chi2=0.0d0
25933         chi12  = chi1 * chi2
25934 !          chip1=0.0d0
25935 !          chip2=0.0d0
25936         chip12 = chip1 * chip2
25937 !          chis1 = 0.0d0
25938 !          chis2 = 0.0d0
25939         chis12 = chis1 * chis2
25940         sig1 = sigmap1_peppho
25941         sig2 = sigmap2_peppho
25942 !       write (*,*) "sig1 = ", sig1
25943 !       write (*,*) "sig1 = ", sig1
25944 !       write (*,*) "sig2 = ", sig2
25945 ! alpha factors from Fcav/Gcav
25946         alf1   = 0.0d0
25947         alf2   = 0.0d0
25948         alf12  = 0.0d0
25949         b1 = alphasur_peppho(1)
25950 !          b1=0.0d0
25951         b2 = alphasur_peppho(2)
25952         b3 = alphasur_peppho(3)
25953         b4 = alphasur_peppho(4)
25954         CALL sc_angular
25955        sqom1=om1*om1
25956        evdwij = 0.0d0
25957        ECL = 0.0d0
25958        Elj = 0.0d0
25959        Equad = 0.0d0
25960        Epol = 0.0d0
25961        Fcav=0.0d0
25962        eheadtail = 0.0d0
25963        dGCLdR=0.0d0
25964        dGCLdOM1 = 0.0d0
25965        dGCLdOM2 = 0.0d0
25966        dGCLdOM12 = 0.0d0
25967        dPOLdOM1 = 0.0d0
25968        dPOLdOM2 = 0.0d0
25969         Fcav = 0.0d0
25970         dFdR = 0.0d0
25971         dCAVdOM1  = 0.0d0
25972         dCAVdOM2  = 0.0d0
25973         dCAVdOM12 = 0.0d0
25974         rij_shift = rij
25975         fac       = rij_shift**expon
25976         c1        = fac  * fac * aa_peppho
25977 !          c1        = 0.0d0
25978         c2        = fac  * bb_peppho
25979 !          c2        = 0.0d0
25980         evdwij    =  c1 + c2
25981 ! Now cavity....................
25982        eagle = dsqrt(1.0/rij_shift)
25983        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
25984         bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
25985         botsq = bot * bot
25986         Fcav = top / bot
25987         dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
25988         dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
25989         dFdR = ((dtop * bot - top * dbot) / botsq)
25990        w1        = wqdip_peppho(1)
25991        w2        = wqdip_peppho(2)
25992 !       w1=0.0d0
25993 !       w2=0.0d0
25994 !       pis       = sig0head_scbase(itypi,itypj)
25995 !       eps_head   = epshead_scbase(itypi,itypj)
25996 !c!-------------------------------------------------------------------
25997
25998 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25999 !c!     &        +dhead(1,1,itypi,itypj))**2))
26000 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26001 !c!     &        +dhead(2,1,itypi,itypj))**2))
26002
26003 !c!-------------------------------------------------------------------
26004 !c! ecl
26005        sparrow  = w1  *  om1
26006        hawk     = w2 *  (1.0d0 - sqom1)
26007        Ecl = sparrow * rij_shift**2.0d0 &
26008          - hawk    * rij_shift**4.0d0
26009 !c!-------------------------------------------------------------------
26010 !c! derivative of ecl is Gcl
26011 !c! dF/dr part
26012 !       rij_shift=5.0
26013        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
26014             + 4.0d0 * hawk    * rij_shift**5.0d0
26015 !c! dF/dom1
26016        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
26017 !c! dF/dom2
26018        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
26019        eom1  =    dGCLdOM1+dGCLdOM2
26020        eom2  =    0.0
26021
26022         fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
26023 !          fac=0.0
26024         gg(1) =  fac*xj*rij
26025         gg(2) =  fac*yj*rij
26026         gg(3) =  fac*zj*rij
26027        do k=1,3
26028        gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
26029        gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
26030        gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
26031        gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
26032        gg(k)=0.0
26033        enddo
26034
26035       DO k = 1, 3
26036       dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
26037       dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
26038       gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
26039       gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
26040 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
26041       gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
26042 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
26043       gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
26044              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
26045       gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
26046              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
26047       enddo
26048        epeppho=epeppho+evdwij+Fcav+ECL
26049 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
26050        enddo
26051        enddo
26052       end subroutine eprot_pep_phosphate
26053 !!!!!!!!!!!!!!!!-------------------------------------------------------------
26054       subroutine emomo(evdw)
26055       use calc_data
26056       use comm_momo
26057 !      implicit real*8 (a-h,o-z)
26058 !      include 'DIMENSIONS'
26059 !      include 'COMMON.GEO'
26060 !      include 'COMMON.VAR'
26061 !      include 'COMMON.LOCAL'
26062 !      include 'COMMON.CHAIN'
26063 !      include 'COMMON.DERIV'
26064 !      include 'COMMON.NAMES'
26065 !      include 'COMMON.INTERACT'
26066 !      include 'COMMON.IOUNITS'
26067 !      include 'COMMON.CALC'
26068 !      include 'COMMON.CONTROL'
26069 !      include 'COMMON.SBRIDGE'
26070       logical :: lprn
26071 !el local variables
26072       integer :: iint,itypi1,subchap,isel
26073       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
26074       real(kind=8) :: evdw,aa,bb
26075       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
26076                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
26077                 sslipi,sslipj,faclip,alpha_sco
26078       integer :: ii
26079       real(kind=8) :: fracinbuf
26080        real (kind=8) :: escpho
26081        real (kind=8),dimension(4):: ener
26082        real(kind=8) :: b1,b2,egb
26083        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
26084       Lambf,&
26085       Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
26086       dFdOM2,dFdL,dFdOM12,&
26087       federmaus,&
26088       d1i,d1j
26089 !       real(kind=8),dimension(3,2)::erhead_tail
26090 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
26091        real(kind=8) ::  facd4, adler, Fgb, facd3
26092        integer troll,jj,istate
26093        real (kind=8) :: dcosom1(3),dcosom2(3)
26094        evdw=0.0d0
26095        eps_out=80.0d0
26096        sss_ele_cut=1.0d0
26097 !       print *,"EVDW KURW",evdw,nres
26098       do i=iatsc_s,iatsc_e
26099 !        print *,"I am in EVDW",i
26100       itypi=iabs(itype(i,1))
26101 !        if (i.ne.47) cycle
26102       if (itypi.eq.ntyp1) cycle
26103       itypi1=iabs(itype(i+1,1))
26104       xi=c(1,nres+i)
26105       yi=c(2,nres+i)
26106       zi=c(3,nres+i)
26107         call to_box(xi,yi,zi)
26108         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
26109 !       endif
26110 !       print *, sslipi,ssgradlipi
26111       dxi=dc_norm(1,nres+i)
26112       dyi=dc_norm(2,nres+i)
26113       dzi=dc_norm(3,nres+i)
26114 !        dsci_inv=dsc_inv(itypi)
26115       dsci_inv=vbld_inv(i+nres)
26116 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
26117 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
26118 !
26119 ! Calculate SC interaction energy.
26120 !
26121       do iint=1,nint_gr(i)
26122         do j=istart(i,iint),iend(i,iint)
26123 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
26124           IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
26125             call dyn_ssbond_ene(i,j,evdwij)
26126             evdw=evdw+evdwij
26127             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
26128                         'evdw',i,j,evdwij,' ss'
26129 !              if (energy_dec) write (iout,*) &
26130 !                              'evdw',i,j,evdwij,' ss'
26131            do k=j+1,iend(i,iint)
26132 !C search over all next residues
26133             if (dyn_ss_mask(k)) then
26134 !C check if they are cysteins
26135 !C              write(iout,*) 'k=',k
26136
26137 !c              write(iout,*) "PRZED TRI", evdwij
26138 !               evdwij_przed_tri=evdwij
26139             call triple_ssbond_ene(i,j,k,evdwij)
26140 !c               if(evdwij_przed_tri.ne.evdwij) then
26141 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
26142 !c               endif
26143
26144 !c              write(iout,*) "PO TRI", evdwij
26145 !C call the energy function that removes the artifical triple disulfide
26146 !C bond the soubroutine is located in ssMD.F
26147             evdw=evdw+evdwij
26148             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
26149                       'evdw',i,j,evdwij,'tss'
26150             endif!dyn_ss_mask(k)
26151            enddo! k
26152           ELSE
26153 !el            ind=ind+1
26154           itypj=iabs(itype(j,1))
26155           if (itypj.eq.ntyp1) cycle
26156            CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
26157
26158 !             if (j.ne.78) cycle
26159 !            dscj_inv=dsc_inv(itypj)
26160           dscj_inv=vbld_inv(j+nres)
26161          xj=c(1,j+nres)
26162          yj=c(2,j+nres)
26163          zj=c(3,j+nres)
26164      call to_box(xj,yj,zj)
26165      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
26166 !      write(iout,*) "KRUWA", i,j
26167       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
26168       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
26169       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
26170       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
26171       xj=boxshift(xj-xi,boxxsize)
26172       yj=boxshift(yj-yi,boxysize)
26173       zj=boxshift(zj-zi,boxzsize)
26174         dxj = dc_norm( 1, nres+j )
26175         dyj = dc_norm( 2, nres+j )
26176         dzj = dc_norm( 3, nres+j )
26177 !          print *,i,j,itypi,itypj
26178 !          d1i=0.0d0
26179 !          d1j=0.0d0
26180 !          BetaT = 1.0d0 / (298.0d0 * Rb)
26181 ! Gay-berne var's
26182 !1!          sig0ij = sigma_scsc( itypi,itypj )
26183 !          chi1=0.0d0
26184 !          chi2=0.0d0
26185 !          chip1=0.0d0
26186 !          chip2=0.0d0
26187 ! not used by momo potential, but needed by sc_angular which is shared
26188 ! by all energy_potential subroutines
26189         alf1   = 0.0d0
26190         alf2   = 0.0d0
26191         alf12  = 0.0d0
26192         a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
26193 !       a12sq = a12sq * a12sq
26194 ! charge of amino acid itypi is...
26195         chis1 = chis(itypi,itypj)
26196         chis2 = chis(itypj,itypi)
26197         chis12 = chis1 * chis2
26198         sig1 = sigmap1(itypi,itypj)
26199         sig2 = sigmap2(itypi,itypj)
26200 !       write (*,*) "sig1 = ", sig1
26201 !          chis1=0.0
26202 !          chis2=0.0
26203 !                    chis12 = chis1 * chis2
26204 !          sig1=0.0
26205 !          sig2=0.0
26206 !       write (*,*) "sig2 = ", sig2
26207 ! alpha factors from Fcav/Gcav
26208         b1cav = alphasur(1,itypi,itypj)
26209 !          b1cav=0.0d0
26210         b2cav = alphasur(2,itypi,itypj)
26211         b3cav = alphasur(3,itypi,itypj)
26212         b4cav = alphasur(4,itypi,itypj)
26213 ! used to determine whether we want to do quadrupole calculations
26214        eps_in = epsintab(itypi,itypj)
26215        if (eps_in.eq.0.0) eps_in=1.0
26216
26217        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
26218        Rtail = 0.0d0
26219 !       dtail(1,itypi,itypj)=0.0
26220 !       dtail(2,itypi,itypj)=0.0
26221
26222        DO k = 1, 3
26223       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
26224       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
26225        END DO
26226 !c! tail distances will be themselves usefull elswhere
26227 !c1 (in Gcav, for example)
26228        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
26229        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
26230        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
26231        Rtail = dsqrt( &
26232         (Rtail_distance(1)*Rtail_distance(1)) &
26233       + (Rtail_distance(2)*Rtail_distance(2)) &
26234       + (Rtail_distance(3)*Rtail_distance(3)))
26235
26236 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
26237 !-------------------------------------------------------------------
26238 ! tail location and distance calculations
26239        d1 = dhead(1, 1, itypi, itypj)
26240        d2 = dhead(2, 1, itypi, itypj)
26241
26242        DO k = 1,3
26243 ! location of polar head is computed by taking hydrophobic centre
26244 ! and moving by a d1 * dc_norm vector
26245 ! see unres publications for very informative images
26246       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26247       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26248 ! distance
26249 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
26250 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
26251       Rhead_distance(k) = chead(k,2) - chead(k,1)
26252        END DO
26253 ! pitagoras (root of sum of squares)
26254        Rhead = dsqrt( &
26255         (Rhead_distance(1)*Rhead_distance(1)) &
26256       + (Rhead_distance(2)*Rhead_distance(2)) &
26257       + (Rhead_distance(3)*Rhead_distance(3)))
26258 !-------------------------------------------------------------------
26259 ! zero everything that should be zero'ed
26260        evdwij = 0.0d0
26261        ECL = 0.0d0
26262        Elj = 0.0d0
26263        Equad = 0.0d0
26264        Epol = 0.0d0
26265        Fcav=0.0d0
26266        eheadtail = 0.0d0
26267        dGCLdOM1 = 0.0d0
26268        dGCLdOM2 = 0.0d0
26269        dGCLdOM12 = 0.0d0
26270        dPOLdOM1 = 0.0d0
26271        dPOLdOM2 = 0.0d0
26272         Fcav = 0.0d0
26273         dFdR = 0.0d0
26274         dCAVdOM1  = 0.0d0
26275         dCAVdOM2  = 0.0d0
26276         dCAVdOM12 = 0.0d0
26277         dscj_inv = vbld_inv(j+nres)
26278 !          print *,i,j,dscj_inv,dsci_inv
26279 ! rij holds 1/(distance of Calpha atoms)
26280         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
26281         rij  = dsqrt(rrij)
26282 !----------------------------
26283         CALL sc_angular
26284 ! this should be in elgrad_init but om's are calculated by sc_angular
26285 ! which in turn is used by older potentials
26286 ! om = omega, sqom = om^2
26287         sqom1  = om1 * om1
26288         sqom2  = om2 * om2
26289         sqom12 = om12 * om12
26290
26291 ! now we calculate EGB - Gey-Berne
26292 ! It will be summed up in evdwij and saved in evdw
26293         sigsq     = 1.0D0  / sigsq
26294         sig       = sig0ij * dsqrt(sigsq)
26295 !          rij_shift = 1.0D0  / rij - sig + sig0ij
26296         rij_shift = Rtail - sig + sig0ij
26297         IF (rij_shift.le.0.0D0) THEN
26298          evdw = 1.0D20
26299          RETURN
26300         END IF
26301         sigder = -sig * sigsq
26302         rij_shift = 1.0D0 / rij_shift
26303         fac       = rij_shift**expon
26304         c1        = fac  * fac * aa_aq(itypi,itypj)
26305 !          print *,"ADAM",aa_aq(itypi,itypj)
26306
26307 !          c1        = 0.0d0
26308         c2        = fac  * bb_aq(itypi,itypj)
26309 !          c2        = 0.0d0
26310         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
26311         eps2der   = eps3rt * evdwij
26312         eps3der   = eps2rt * evdwij
26313 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
26314         evdwij    = eps2rt * eps3rt * evdwij
26315 !#ifdef TSCSC
26316 !          IF (bb_aq(itypi,itypj).gt.0) THEN
26317 !           evdw_p = evdw_p + evdwij
26318 !          ELSE
26319 !           evdw_m = evdw_m + evdwij
26320 !          END IF
26321 !#else
26322         evdw = evdw  &
26323             + evdwij
26324 !#endif
26325
26326         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
26327         fac    = -expon * (c1 + evdwij) * rij_shift
26328         sigder = fac * sigder
26329 !          fac    = rij * fac
26330 ! Calculate distance derivative
26331         gg(1) =  fac
26332         gg(2) =  fac
26333         gg(3) =  fac
26334 !          if (b2.gt.0.0) then
26335         fac = chis1 * sqom1 + chis2 * sqom2 &
26336         - 2.0d0 * chis12 * om1 * om2 * om12
26337 ! we will use pom later in Gcav, so dont mess with it!
26338         pom = 1.0d0 - chis1 * chis2 * sqom12
26339         Lambf = (1.0d0 - (fac / pom))
26340 !          print *,"fac,pom",fac,pom,Lambf
26341         Lambf = dsqrt(Lambf)
26342         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
26343 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
26344 !       write (*,*) "sparrow = ", sparrow
26345         Chif = Rtail * sparrow
26346 !           print *,"rij,sparrow",rij , sparrow
26347         ChiLambf = Chif * Lambf
26348         eagle = dsqrt(ChiLambf)
26349         bat = ChiLambf ** 11.0d0
26350         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
26351         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
26352         botsq = bot * bot
26353 !          print *,top,bot,"bot,top",ChiLambf,Chif
26354         Fcav = top / bot
26355
26356        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
26357        dbot = 12.0d0 * b4cav * bat * Lambf
26358        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
26359
26360         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
26361         dbot = 12.0d0 * b4cav * bat * Chif
26362         eagle = Lambf * pom
26363         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
26364         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
26365         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
26366             * (chis2 * om2 * om12 - om1) / (eagle * pom)
26367
26368         dFdL = ((dtop * bot - top * dbot) / botsq)
26369 !       dFdL = 0.0d0
26370         dCAVdOM1  = dFdL * ( dFdOM1 )
26371         dCAVdOM2  = dFdL * ( dFdOM2 )
26372         dCAVdOM12 = dFdL * ( dFdOM12 )
26373
26374        DO k= 1, 3
26375       ertail(k) = Rtail_distance(k)/Rtail
26376        END DO
26377        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
26378        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
26379        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26380        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26381        DO k = 1, 3
26382 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
26383 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
26384       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
26385       gvdwx(k,i) = gvdwx(k,i) &
26386               - (( dFdR + gg(k) ) * pom)
26387 !c!     &             - ( dFdR * pom )
26388       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
26389       gvdwx(k,j) = gvdwx(k,j)   &
26390               + (( dFdR + gg(k) ) * pom)
26391 !c!     &             + ( dFdR * pom )
26392
26393       gvdwc(k,i) = gvdwc(k,i)  &
26394               - (( dFdR + gg(k) ) * ertail(k))
26395 !c!     &             - ( dFdR * ertail(k))
26396
26397       gvdwc(k,j) = gvdwc(k,j) &
26398               + (( dFdR + gg(k) ) * ertail(k))
26399 !c!     &             + ( dFdR * ertail(k))
26400
26401       gg(k) = 0.0d0
26402 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
26403 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
26404       END DO
26405
26406
26407 !c! Compute head-head and head-tail energies for each state
26408
26409         isel = iabs(Qi) + iabs(Qj)
26410 ! double charge for Phophorylated! itype - 25,27,27
26411 !          if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then
26412 !            Qi=Qi*2
26413 !            Qij=Qij*2
26414 !           endif
26415 !          if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then
26416 !            Qj=Qj*2
26417 !            Qij=Qij*2
26418 !           endif
26419
26420 !          isel=0
26421         IF (isel.eq.0) THEN
26422 !c! No charges - do nothing
26423          eheadtail = 0.0d0
26424
26425         ELSE IF (isel.eq.4) THEN
26426 !c! Calculate dipole-dipole interactions
26427          CALL edd(ecl)
26428          eheadtail = ECL
26429 !           eheadtail = 0.0d0
26430
26431         ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
26432 !c! Charge-nonpolar interactions
26433         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26434           Qi=Qi*2
26435           Qij=Qij*2
26436          endif
26437         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26438           Qj=Qj*2
26439           Qij=Qij*2
26440          endif
26441
26442          CALL eqn(epol)
26443          eheadtail = epol
26444 !           eheadtail = 0.0d0
26445
26446         ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
26447 !c! Nonpolar-charge interactions
26448         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26449           Qi=Qi*2
26450           Qij=Qij*2
26451          endif
26452         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26453           Qj=Qj*2
26454           Qij=Qij*2
26455          endif
26456
26457          CALL enq(epol)
26458          eheadtail = epol
26459 !           eheadtail = 0.0d0
26460
26461         ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
26462 !c! Charge-dipole interactions
26463         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26464           Qi=Qi*2
26465           Qij=Qij*2
26466          endif
26467         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26468           Qj=Qj*2
26469           Qij=Qij*2
26470          endif
26471
26472          CALL eqd(ecl, elj, epol)
26473          eheadtail = ECL + elj + epol
26474 !           eheadtail = 0.0d0
26475
26476         ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
26477 !c! Dipole-charge interactions
26478         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26479           Qi=Qi*2
26480           Qij=Qij*2
26481          endif
26482         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26483           Qj=Qj*2
26484           Qij=Qij*2
26485          endif
26486          CALL edq(ecl, elj, epol)
26487         eheadtail = ECL + elj + epol
26488 !           eheadtail = 0.0d0
26489
26490         ELSE IF ((isel.eq.2.and.   &
26491              iabs(Qi).eq.1).and.  &
26492              nstate(itypi,itypj).eq.1) THEN
26493 !c! Same charge-charge interaction ( +/+ or -/- )
26494         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26495           Qi=Qi*2
26496           Qij=Qij*2
26497          endif
26498         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26499           Qj=Qj*2
26500           Qij=Qij*2
26501          endif
26502
26503          CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
26504          eheadtail = ECL + Egb + Epol + Fisocav + Elj
26505 !           eheadtail = 0.0d0
26506
26507         ELSE IF ((isel.eq.2.and.  &
26508              iabs(Qi).eq.1).and. &
26509              nstate(itypi,itypj).ne.1) THEN
26510 !c! Different charge-charge interaction ( +/- or -/+ )
26511         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26512           Qi=Qi*2
26513           Qij=Qij*2
26514          endif
26515         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26516           Qj=Qj*2
26517           Qij=Qij*2
26518          endif
26519
26520          CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
26521         END IF
26522        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
26523       evdw = evdw  + Fcav + eheadtail
26524
26525        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
26526       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
26527       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
26528       Equad,evdwij+Fcav+eheadtail,evdw
26529 !       evdw = evdw  + Fcav  + eheadtail
26530
26531       iF (nstate(itypi,itypj).eq.1) THEN
26532       CALL sc_grad
26533        END IF
26534 !c!-------------------------------------------------------------------
26535 !c! NAPISY KONCOWE
26536        END DO   ! j
26537       END DO    ! iint
26538        END DO     ! i
26539 !c      write (iout,*) "Number of loop steps in EGB:",ind
26540 !c      energy_dec=.false.
26541 !              print *,"EVDW KURW",evdw,nres
26542
26543        RETURN
26544       END SUBROUTINE emomo
26545 !C------------------------------------------------------------------------------------
26546       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
26547       use calc_data
26548       use comm_momo
26549        real (kind=8) ::  facd3, facd4, federmaus, adler,&
26550        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
26551 !       integer :: k
26552 !c! Epol and Gpol analytical parameters
26553        alphapol1 = alphapol(itypi,itypj)
26554        alphapol2 = alphapol(itypj,itypi)
26555 !c! Fisocav and Gisocav analytical parameters
26556        al1  = alphiso(1,itypi,itypj)
26557        al2  = alphiso(2,itypi,itypj)
26558        al3  = alphiso(3,itypi,itypj)
26559        al4  = alphiso(4,itypi,itypj)
26560        csig = (1.0d0  &
26561          / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
26562          + sigiso2(itypi,itypj)**2.0d0))
26563 !c!
26564        pis  = sig0head(itypi,itypj)
26565        eps_head = epshead(itypi,itypj)
26566        Rhead_sq = Rhead * Rhead
26567 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26568 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26569        R1 = 0.0d0
26570        R2 = 0.0d0
26571        DO k = 1, 3
26572 !c! Calculate head-to-tail distances needed by Epol
26573       R1=R1+(ctail(k,2)-chead(k,1))**2
26574       R2=R2+(chead(k,2)-ctail(k,1))**2
26575        END DO
26576 !c! Pitagoras
26577        R1 = dsqrt(R1)
26578        R2 = dsqrt(R2)
26579
26580 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26581 !c!     &        +dhead(1,1,itypi,itypj))**2))
26582 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26583 !c!     &        +dhead(2,1,itypi,itypj))**2))
26584
26585 !c!-------------------------------------------------------------------
26586 !c! Coulomb electrostatic interaction
26587        Ecl = (332.0d0 * Qij) / Rhead
26588 !c! derivative of Ecl is Gcl...
26589        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
26590        dGCLdOM1 = 0.0d0
26591        dGCLdOM2 = 0.0d0
26592        dGCLdOM12 = 0.0d0
26593        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26594        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26595        debkap=debaykap(itypi,itypj)
26596        Egb = -(332.0d0 * Qij *&
26597       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
26598 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
26599 !c! Derivative of Egb is Ggb...
26600        dGGBdFGB = -(-332.0d0 * Qij * &
26601        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
26602        -(332.0d0 * Qij *&
26603       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
26604        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
26605        dGGBdR = dGGBdFGB * dFGBdR
26606 !c!-------------------------------------------------------------------
26607 !c! Fisocav - isotropic cavity creation term
26608 !c! or "how much energy it costs to put charged head in water"
26609        pom = Rhead * csig
26610        top = al1 * (dsqrt(pom) + al2 * pom - al3)
26611        bot = (1.0d0 + al4 * pom**12.0d0)
26612        botsq = bot * bot
26613        FisoCav = top / bot
26614 !      write (*,*) "Rhead = ",Rhead
26615 !      write (*,*) "csig = ",csig
26616 !      write (*,*) "pom = ",pom
26617 !      write (*,*) "al1 = ",al1
26618 !      write (*,*) "al2 = ",al2
26619 !      write (*,*) "al3 = ",al3
26620 !      write (*,*) "al4 = ",al4
26621 !        write (*,*) "top = ",top
26622 !        write (*,*) "bot = ",bot
26623 !c! Derivative of Fisocav is GCV...
26624        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26625        dbot = 12.0d0 * al4 * pom ** 11.0d0
26626        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26627 !c!-------------------------------------------------------------------
26628 !c! Epol
26629 !c! Polarization energy - charged heads polarize hydrophobic "neck"
26630        MomoFac1 = (1.0d0 - chi1 * sqom2)
26631        MomoFac2 = (1.0d0 - chi2 * sqom1)
26632        RR1  = ( R1 * R1 ) / MomoFac1
26633        RR2  = ( R2 * R2 ) / MomoFac2
26634        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26635        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26636        fgb1 = sqrt( RR1 + a12sq * ee1 )
26637        fgb2 = sqrt( RR2 + a12sq * ee2 )
26638        epol = 332.0d0 * eps_inout_fac * ( &
26639       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26640 !c!       epol = 0.0d0
26641        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26642              / (fgb1 ** 5.0d0)
26643        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26644              / (fgb2 ** 5.0d0)
26645        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
26646            / ( 2.0d0 * fgb1 )
26647        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
26648            / ( 2.0d0 * fgb2 )
26649        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
26650             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
26651        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
26652             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
26653        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26654 !c!       dPOLdR1 = 0.0d0
26655        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26656 !c!       dPOLdR2 = 0.0d0
26657        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26658 !c!       dPOLdOM1 = 0.0d0
26659        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26660 !c!       dPOLdOM2 = 0.0d0
26661 !c!-------------------------------------------------------------------
26662 !c! Elj
26663 !c! Lennard-Jones 6-12 interaction between heads
26664        pom = (pis / Rhead)**6.0d0
26665        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26666 !c! derivative of Elj is Glj
26667        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
26668            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26669 !c!-------------------------------------------------------------------
26670 !c! Return the results
26671 !c! These things do the dRdX derivatives, that is
26672 !c! allow us to change what we see from function that changes with
26673 !c! distance to function that changes with LOCATION (of the interaction
26674 !c! site)
26675        DO k = 1, 3
26676       erhead(k) = Rhead_distance(k)/Rhead
26677       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26678       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26679        END DO
26680
26681        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26682        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26683        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26684        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26685        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26686        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26687        facd1 = d1 * vbld_inv(i+nres)
26688        facd2 = d2 * vbld_inv(j+nres)
26689        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26690        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26691
26692 !c! Now we add appropriate partial derivatives (one in each dimension)
26693        DO k = 1, 3
26694       hawk   = (erhead_tail(k,1) + &
26695       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
26696       condor = (erhead_tail(k,2) + &
26697       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26698
26699       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26700       gvdwx(k,i) = gvdwx(k,i) &
26701               - dGCLdR * pom&
26702               - dGGBdR * pom&
26703               - dGCVdR * pom&
26704               - dPOLdR1 * hawk&
26705               - dPOLdR2 * (erhead_tail(k,2)&
26706       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26707               - dGLJdR * pom
26708
26709       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26710       gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
26711                + dGGBdR * pom+ dGCVdR * pom&
26712               + dPOLdR1 * (erhead_tail(k,1)&
26713       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
26714               + dPOLdR2 * condor + dGLJdR * pom
26715
26716       gvdwc(k,i) = gvdwc(k,i)  &
26717               - dGCLdR * erhead(k)&
26718               - dGGBdR * erhead(k)&
26719               - dGCVdR * erhead(k)&
26720               - dPOLdR1 * erhead_tail(k,1)&
26721               - dPOLdR2 * erhead_tail(k,2)&
26722               - dGLJdR * erhead(k)
26723
26724       gvdwc(k,j) = gvdwc(k,j)         &
26725               + dGCLdR * erhead(k) &
26726               + dGGBdR * erhead(k) &
26727               + dGCVdR * erhead(k) &
26728               + dPOLdR1 * erhead_tail(k,1) &
26729               + dPOLdR2 * erhead_tail(k,2)&
26730               + dGLJdR * erhead(k)
26731
26732        END DO
26733        RETURN
26734       END SUBROUTINE eqq
26735
26736       SUBROUTINE eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
26737       use calc_data
26738       use comm_momo
26739        real (kind=8) ::  facd3, facd4, federmaus, adler,&
26740        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
26741 !       integer :: k
26742 !c! Epol and Gpol analytical parameters
26743        alphapol1 = alphapolcat(itypi,itypj)
26744        alphapol2 = alphapolcat2(itypj,itypi)
26745 !c! Fisocav and Gisocav analytical parameters
26746        al1  = alphisocat(1,itypi,itypj)
26747        al2  = alphisocat(2,itypi,itypj)
26748        al3  = alphisocat(3,itypi,itypj)
26749        al4  = alphisocat(4,itypi,itypj)
26750        csig = (1.0d0  &
26751          / dsqrt(sigiso1cat(itypi, itypj)**2.0d0 &
26752          + sigiso2cat(itypi,itypj)**2.0d0))
26753 !c!
26754        pis  = sig0headcat(itypi,itypj)
26755        eps_head = epsheadcat(itypi,itypj)
26756        Rhead_sq = Rhead * Rhead
26757 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26758 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26759        R1 = 0.0d0
26760        R2 = 0.0d0
26761        DO k = 1, 3
26762 !c! Calculate head-to-tail distances needed by Epol
26763       R1=R1+(ctail(k,2)-chead(k,1))**2
26764       R2=R2+(chead(k,2)-ctail(k,1))**2
26765        END DO
26766 !c! Pitagoras
26767        R1 = dsqrt(R1)
26768        R2 = dsqrt(R2)
26769
26770 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26771 !c!     &        +dhead(1,1,itypi,itypj))**2))
26772 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26773 !c!     &        +dhead(2,1,itypi,itypj))**2))
26774
26775 !c!-------------------------------------------------------------------
26776 !c! Coulomb electrostatic interaction
26777        Ecl = (332.0d0 * Qij) / Rhead
26778 !c! derivative of Ecl is Gcl...
26779        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
26780        dGCLdOM1 = 0.0d0
26781        dGCLdOM2 = 0.0d0
26782        dGCLdOM12 = 0.0d0
26783        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26784        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26785        debkap=debaykapcat(itypi,itypj)
26786        Egb = -(332.0d0 * Qij *&
26787       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
26788 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
26789 !c! Derivative of Egb is Ggb...
26790        dGGBdFGB = -(-332.0d0 * Qij * &
26791        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
26792        -(332.0d0 * Qij *&
26793       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
26794        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
26795        dGGBdR = dGGBdFGB * dFGBdR
26796 !c!-------------------------------------------------------------------
26797 !c! Fisocav - isotropic cavity creation term
26798 !c! or "how much energy it costs to put charged head in water"
26799        pom = Rhead * csig
26800        top = al1 * (dsqrt(pom) + al2 * pom - al3)
26801        bot = (1.0d0 + al4 * pom**12.0d0)
26802        botsq = bot * bot
26803        FisoCav = top / bot
26804 !      write (*,*) "Rhead = ",Rhead
26805 !      write (*,*) "csig = ",csig
26806 !      write (*,*) "pom = ",pom
26807 !      write (*,*) "al1 = ",al1
26808 !      write (*,*) "al2 = ",al2
26809 !      write (*,*) "al3 = ",al3
26810 !      write (*,*) "al4 = ",al4
26811 !        write (*,*) "top = ",top
26812 !        write (*,*) "bot = ",bot
26813 !c! Derivative of Fisocav is GCV...
26814        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26815        dbot = 12.0d0 * al4 * pom ** 11.0d0
26816        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26817 !c!-------------------------------------------------------------------
26818 !c! Epol
26819 !c! Polarization energy - charged heads polarize hydrophobic "neck"
26820        MomoFac1 = (1.0d0 - chi1 * sqom2)
26821        MomoFac2 = (1.0d0 - chi2 * sqom1)
26822        RR1  = ( R1 * R1 ) / MomoFac1
26823        RR2  = ( R2 * R2 ) / MomoFac2
26824        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26825        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26826        fgb1 = sqrt( RR1 + a12sq * ee1 )
26827        fgb2 = sqrt( RR2 + a12sq * ee2 )
26828        epol = 332.0d0 * eps_inout_fac * ( &
26829       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26830 !c!       epol = 0.0d0
26831        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26832              / (fgb1 ** 5.0d0)
26833        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26834              / (fgb2 ** 5.0d0)
26835        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
26836            / ( 2.0d0 * fgb1 )
26837        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
26838            / ( 2.0d0 * fgb2 )
26839        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
26840             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
26841        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
26842             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
26843        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26844 !c!       dPOLdR1 = 0.0d0
26845        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26846 !c!       dPOLdR2 = 0.0d0
26847        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26848 !c!       dPOLdOM1 = 0.0d0
26849        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26850 !c!       dPOLdOM2 = 0.0d0
26851 !c!-------------------------------------------------------------------
26852 !c! Elj
26853 !c! Lennard-Jones 6-12 interaction between heads
26854        pom = (pis / Rhead)**6.0d0
26855        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26856 !c! derivative of Elj is Glj
26857        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
26858            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26859 !c!-------------------------------------------------------------------
26860 !c! Return the results
26861 !c! These things do the dRdX derivatives, that is
26862 !c! allow us to change what we see from function that changes with
26863 !c! distance to function that changes with LOCATION (of the interaction
26864 !c! site)
26865        DO k = 1, 3
26866       erhead(k) = Rhead_distance(k)/Rhead
26867       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26868       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26869        END DO
26870
26871        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26872        erdxj = scalar( erhead(1), dC_norm(1,j) )
26873        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26874        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
26875        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26876        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26877        facd1 = d1 * vbld_inv(i+nres)
26878        facd2 = d2 * vbld_inv(j)
26879        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26880        facd4 = dtailcat(2,itypi,itypj) * vbld_inv(j)
26881
26882 !c! Now we add appropriate partial derivatives (one in each dimension)
26883        DO k = 1, 3
26884       hawk   = (erhead_tail(k,1) + &
26885       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
26886       condor = (erhead_tail(k,2) + &
26887       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26888
26889       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26890       gradpepcatx(k,i) = gradpepcatx(k,i) &
26891               - dGCLdR * pom&
26892               - dGGBdR * pom&
26893               - dGCVdR * pom&
26894               - dPOLdR1 * hawk&
26895               - dPOLdR2 * (erhead_tail(k,2)&
26896       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26897               - dGLJdR * pom
26898
26899       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
26900 !        gradpepcatx(k,j) = gradpepcatx(k,j)+ dGCLdR * pom&
26901 !                   + dGGBdR * pom+ dGCVdR * pom&
26902 !                  + dPOLdR1 * (erhead_tail(k,1)&
26903 !      -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j)))&
26904 !                  + dPOLdR2 * condor + dGLJdR * pom
26905
26906       gradpepcat(k,i) = gradpepcat(k,i)  &
26907               - dGCLdR * erhead(k)&
26908               - dGGBdR * erhead(k)&
26909               - dGCVdR * erhead(k)&
26910               - dPOLdR1 * erhead_tail(k,1)&
26911               - dPOLdR2 * erhead_tail(k,2)&
26912               - dGLJdR * erhead(k)
26913
26914       gradpepcat(k,j) = gradpepcat(k,j)         &
26915               + dGCLdR * erhead(k) &
26916               + dGGBdR * erhead(k) &
26917               + dGCVdR * erhead(k) &
26918               + dPOLdR1 * erhead_tail(k,1) &
26919               + dPOLdR2 * erhead_tail(k,2)&
26920               + dGLJdR * erhead(k)
26921
26922        END DO
26923        RETURN
26924       END SUBROUTINE eqq_cat
26925 !c!-------------------------------------------------------------------
26926       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
26927       use comm_momo
26928       use calc_data
26929
26930        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
26931        double precision ener(4)
26932        double precision dcosom1(3),dcosom2(3)
26933 !c! used in Epol derivatives
26934        double precision facd3, facd4
26935        double precision federmaus, adler
26936        integer istate,ii,jj
26937        real (kind=8) :: Fgb
26938 !       print *,"CALLING EQUAD"
26939 !c! Epol and Gpol analytical parameters
26940        alphapol1 = alphapol(itypi,itypj)
26941        alphapol2 = alphapol(itypj,itypi)
26942 !c! Fisocav and Gisocav analytical parameters
26943        al1  = alphiso(1,itypi,itypj)
26944        al2  = alphiso(2,itypi,itypj)
26945        al3  = alphiso(3,itypi,itypj)
26946        al4  = alphiso(4,itypi,itypj)
26947        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
26948           + sigiso2(itypi,itypj)**2.0d0))
26949 !c!
26950        w1   = wqdip(1,itypi,itypj)
26951        w2   = wqdip(2,itypi,itypj)
26952        pis  = sig0head(itypi,itypj)
26953        eps_head = epshead(itypi,itypj)
26954 !c! First things first:
26955 !c! We need to do sc_grad's job with GB and Fcav
26956        eom1  = eps2der * eps2rt_om1 &
26957            - 2.0D0 * alf1 * eps3der&
26958            + sigder * sigsq_om1&
26959            + dCAVdOM1
26960        eom2  = eps2der * eps2rt_om2 &
26961            + 2.0D0 * alf2 * eps3der&
26962            + sigder * sigsq_om2&
26963            + dCAVdOM2
26964        eom12 =  evdwij  * eps1_om12 &
26965            + eps2der * eps2rt_om12 &
26966            - 2.0D0 * alf12 * eps3der&
26967            + sigder *sigsq_om12&
26968            + dCAVdOM12
26969 !c! now some magical transformations to project gradient into
26970 !c! three cartesian vectors
26971        DO k = 1, 3
26972       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26973       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26974       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
26975 !c! this acts on hydrophobic center of interaction
26976       gvdwx(k,i)= gvdwx(k,i) - gg(k) &
26977               + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
26978               + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26979       gvdwx(k,j)= gvdwx(k,j) + gg(k) &
26980               + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
26981               + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26982 !c! this acts on Calpha
26983       gvdwc(k,i)=gvdwc(k,i)-gg(k)
26984       gvdwc(k,j)=gvdwc(k,j)+gg(k)
26985        END DO
26986 !c! sc_grad is done, now we will compute
26987        eheadtail = 0.0d0
26988        eom1 = 0.0d0
26989        eom2 = 0.0d0
26990        eom12 = 0.0d0
26991        DO istate = 1, nstate(itypi,itypj)
26992 !c*************************************************************
26993       IF (istate.ne.1) THEN
26994        IF (istate.lt.3) THEN
26995         ii = 1
26996        ELSE
26997         ii = 2
26998        END IF
26999       jj = istate/ii
27000       d1 = dhead(1,ii,itypi,itypj)
27001       d2 = dhead(2,jj,itypi,itypj)
27002       DO k = 1,3
27003        chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
27004        chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
27005        Rhead_distance(k) = chead(k,2) - chead(k,1)
27006       END DO
27007 !c! pitagoras (root of sum of squares)
27008       Rhead = dsqrt( &
27009              (Rhead_distance(1)*Rhead_distance(1))  &
27010            + (Rhead_distance(2)*Rhead_distance(2))  &
27011            + (Rhead_distance(3)*Rhead_distance(3)))
27012       END IF
27013       Rhead_sq = Rhead * Rhead
27014
27015 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27016 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27017       R1 = 0.0d0
27018       R2 = 0.0d0
27019       DO k = 1, 3
27020 !c! Calculate head-to-tail distances
27021        R1=R1+(ctail(k,2)-chead(k,1))**2
27022        R2=R2+(chead(k,2)-ctail(k,1))**2
27023       END DO
27024 !c! Pitagoras
27025       R1 = dsqrt(R1)
27026       R2 = dsqrt(R2)
27027       Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
27028 !c!        Ecl = 0.0d0
27029 !c!        write (*,*) "Ecl = ", Ecl
27030 !c! derivative of Ecl is Gcl...
27031       dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
27032 !c!        dGCLdR = 0.0d0
27033       dGCLdOM1 = 0.0d0
27034       dGCLdOM2 = 0.0d0
27035       dGCLdOM12 = 0.0d0
27036 !c!-------------------------------------------------------------------
27037 !c! Generalised Born Solvent Polarization
27038       ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
27039       Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
27040       Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
27041 !c!        Egb = 0.0d0
27042 !c!      write (*,*) "a1*a2 = ", a12sq
27043 !c!      write (*,*) "Rhead = ", Rhead
27044 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
27045 !c!      write (*,*) "ee = ", ee
27046 !c!      write (*,*) "Fgb = ", Fgb
27047 !c!      write (*,*) "fac = ", eps_inout_fac
27048 !c!      write (*,*) "Qij = ", Qij
27049 !c!      write (*,*) "Egb = ", Egb
27050 !c! Derivative of Egb is Ggb...
27051 !c! dFGBdR is used by Quad's later...
27052       dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
27053       dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
27054              / ( 2.0d0 * Fgb )
27055       dGGBdR = dGGBdFGB * dFGBdR
27056 !c!        dGGBdR = 0.0d0
27057 !c!-------------------------------------------------------------------
27058 !c! Fisocav - isotropic cavity creation term
27059       pom = Rhead * csig
27060       top = al1 * (dsqrt(pom) + al2 * pom - al3)
27061       bot = (1.0d0 + al4 * pom**12.0d0)
27062       botsq = bot * bot
27063       FisoCav = top / bot
27064       dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
27065       dbot = 12.0d0 * al4 * pom ** 11.0d0
27066       dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
27067 !c!        dGCVdR = 0.0d0
27068 !c!-------------------------------------------------------------------
27069 !c! Polarization energy
27070 !c! Epol
27071       MomoFac1 = (1.0d0 - chi1 * sqom2)
27072       MomoFac2 = (1.0d0 - chi2 * sqom1)
27073       RR1  = ( R1 * R1 ) / MomoFac1
27074       RR2  = ( R2 * R2 ) / MomoFac2
27075       ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27076       ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
27077       fgb1 = sqrt( RR1 + a12sq * ee1 )
27078       fgb2 = sqrt( RR2 + a12sq * ee2 )
27079       epol = 332.0d0 * eps_inout_fac * (&
27080       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
27081 !c!        epol = 0.0d0
27082 !c! derivative of Epol is Gpol...
27083       dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
27084               / (fgb1 ** 5.0d0)
27085       dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
27086               / (fgb2 ** 5.0d0)
27087       dFGBdR1 = ( (R1 / MomoFac1) &
27088             * ( 2.0d0 - (0.5d0 * ee1) ) )&
27089             / ( 2.0d0 * fgb1 )
27090       dFGBdR2 = ( (R2 / MomoFac2) &
27091             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27092             / ( 2.0d0 * fgb2 )
27093       dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
27094              * ( 2.0d0 - 0.5d0 * ee1) ) &
27095              / ( 2.0d0 * fgb1 )
27096       dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27097              * ( 2.0d0 - 0.5d0 * ee2) ) &
27098              / ( 2.0d0 * fgb2 )
27099       dPOLdR1 = dPOLdFGB1 * dFGBdR1
27100 !c!        dPOLdR1 = 0.0d0
27101       dPOLdR2 = dPOLdFGB2 * dFGBdR2
27102 !c!        dPOLdR2 = 0.0d0
27103       dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27104 !c!        dPOLdOM1 = 0.0d0
27105       dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27106       pom = (pis / Rhead)**6.0d0
27107       Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27108 !c!        Elj = 0.0d0
27109 !c! derivative of Elj is Glj
27110       dGLJdR = 4.0d0 * eps_head &
27111           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27112           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27113 !c!        dGLJdR = 0.0d0
27114 !c!-------------------------------------------------------------------
27115 !c! Equad
27116        IF (Wqd.ne.0.0d0) THEN
27117       Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
27118            - 37.5d0  * ( sqom1 + sqom2 ) &
27119            + 157.5d0 * ( sqom1 * sqom2 ) &
27120            - 45.0d0  * om1*om2*om12
27121       fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
27122       Equad = fac * Beta1
27123 !c!        Equad = 0.0d0
27124 !c! derivative of Equad...
27125       dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
27126 !c!        dQUADdR = 0.0d0
27127       dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
27128 !c!        dQUADdOM1 = 0.0d0
27129       dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
27130 !c!        dQUADdOM2 = 0.0d0
27131       dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
27132        ELSE
27133        Beta1 = 0.0d0
27134        Equad = 0.0d0
27135       END IF
27136 !c!-------------------------------------------------------------------
27137 !c! Return the results
27138 !c! Angular stuff
27139       eom1 = dPOLdOM1 + dQUADdOM1
27140       eom2 = dPOLdOM2 + dQUADdOM2
27141       eom12 = dQUADdOM12
27142 !c! now some magical transformations to project gradient into
27143 !c! three cartesian vectors
27144       DO k = 1, 3
27145        dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
27146        dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
27147        tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
27148       END DO
27149 !c! Radial stuff
27150       DO k = 1, 3
27151        erhead(k) = Rhead_distance(k)/Rhead
27152        erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27153        erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27154       END DO
27155       erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27156       erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27157       bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27158       federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27159       eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27160       adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27161       facd1 = d1 * vbld_inv(i+nres)
27162       facd2 = d2 * vbld_inv(j+nres)
27163       facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27164       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27165       DO k = 1, 3
27166        hawk   = erhead_tail(k,1) + &
27167        facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
27168        condor = erhead_tail(k,2) + &
27169        facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
27170
27171        pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27172 !c! this acts on hydrophobic center of interaction
27173        gheadtail(k,1,1) = gheadtail(k,1,1) &
27174                    - dGCLdR * pom &
27175                    - dGGBdR * pom &
27176                    - dGCVdR * pom &
27177                    - dPOLdR1 * hawk &
27178                    - dPOLdR2 * (erhead_tail(k,2) &
27179       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
27180                    - dGLJdR * pom &
27181                    - dQUADdR * pom&
27182                    - tuna(k) &
27183              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
27184              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
27185
27186        pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27187 !c! this acts on hydrophobic center of interaction
27188        gheadtail(k,2,1) = gheadtail(k,2,1)  &
27189                    + dGCLdR * pom      &
27190                    + dGGBdR * pom      &
27191                    + dGCVdR * pom      &
27192                    + dPOLdR1 * (erhead_tail(k,1) &
27193       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
27194                    + dPOLdR2 * condor &
27195                    + dGLJdR * pom &
27196                    + dQUADdR * pom &
27197                    + tuna(k) &
27198              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
27199              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
27200
27201 !c! this acts on Calpha
27202        gheadtail(k,3,1) = gheadtail(k,3,1)  &
27203                    - dGCLdR * erhead(k)&
27204                    - dGGBdR * erhead(k)&
27205                    - dGCVdR * erhead(k)&
27206                    - dPOLdR1 * erhead_tail(k,1)&
27207                    - dPOLdR2 * erhead_tail(k,2)&
27208                    - dGLJdR * erhead(k) &
27209                    - dQUADdR * erhead(k)&
27210                    - tuna(k)
27211 !c! this acts on Calpha
27212        gheadtail(k,4,1) = gheadtail(k,4,1)   &
27213                     + dGCLdR * erhead(k) &
27214                     + dGGBdR * erhead(k) &
27215                     + dGCVdR * erhead(k) &
27216                     + dPOLdR1 * erhead_tail(k,1) &
27217                     + dPOLdR2 * erhead_tail(k,2) &
27218                     + dGLJdR * erhead(k) &
27219                     + dQUADdR * erhead(k)&
27220                     + tuna(k)
27221       END DO
27222       ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
27223       eheadtail = eheadtail &
27224               + wstate(istate, itypi, itypj) &
27225               * dexp(-betaT * ener(istate))
27226 !c! foreach cartesian dimension
27227       DO k = 1, 3
27228 !c! foreach of two gvdwx and gvdwc
27229        DO l = 1, 4
27230         gheadtail(k,l,2) = gheadtail(k,l,2)  &
27231                      + wstate( istate, itypi, itypj ) &
27232                      * dexp(-betaT * ener(istate)) &
27233                      * gheadtail(k,l,1)
27234         gheadtail(k,l,1) = 0.0d0
27235        END DO
27236       END DO
27237        END DO
27238 !c! Here ended the gigantic DO istate = 1, 4, which starts
27239 !c! at the beggining of the subroutine
27240
27241        DO k = 1, 3
27242       DO l = 1, 4
27243        gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
27244       END DO
27245       gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
27246       gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
27247       gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
27248       gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
27249       DO l = 1, 4
27250        gheadtail(k,l,1) = 0.0d0
27251        gheadtail(k,l,2) = 0.0d0
27252       END DO
27253        END DO
27254        eheadtail = (-dlog(eheadtail)) / betaT
27255        dPOLdOM1 = 0.0d0
27256        dPOLdOM2 = 0.0d0
27257        dQUADdOM1 = 0.0d0
27258        dQUADdOM2 = 0.0d0
27259        dQUADdOM12 = 0.0d0
27260        RETURN
27261       END SUBROUTINE energy_quad
27262 !!-----------------------------------------------------------
27263       SUBROUTINE eqn(Epol)
27264       use comm_momo
27265       use calc_data
27266
27267       double precision  facd4, federmaus,epol
27268       alphapol1 = alphapol(itypi,itypj)
27269 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27270        R1 = 0.0d0
27271        DO k = 1, 3
27272 !c! Calculate head-to-tail distances
27273       R1=R1+(ctail(k,2)-chead(k,1))**2
27274        END DO
27275 !c! Pitagoras
27276        R1 = dsqrt(R1)
27277
27278 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27279 !c!     &        +dhead(1,1,itypi,itypj))**2))
27280 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27281 !c!     &        +dhead(2,1,itypi,itypj))**2))
27282 !c--------------------------------------------------------------------
27283 !c Polarization energy
27284 !c Epol
27285        MomoFac1 = (1.0d0 - chi1 * sqom2)
27286        RR1  = R1 * R1 / MomoFac1
27287        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27288        fgb1 = sqrt( RR1 + a12sq * ee1)
27289        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
27290        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
27291              / (fgb1 ** 5.0d0)
27292        dFGBdR1 = ( (R1 / MomoFac1) &
27293             * ( 2.0d0 - (0.5d0 * ee1) ) ) &
27294             / ( 2.0d0 * fgb1 )
27295        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
27296             * (2.0d0 - 0.5d0 * ee1) ) &
27297             / (2.0d0 * fgb1)
27298        dPOLdR1 = dPOLdFGB1 * dFGBdR1
27299 !c!       dPOLdR1 = 0.0d0
27300        dPOLdOM1 = 0.0d0
27301        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27302        DO k = 1, 3
27303       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27304        END DO
27305        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27306        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27307        facd1 = d1 * vbld_inv(i+nres)
27308        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27309
27310        DO k = 1, 3
27311       hawk = (erhead_tail(k,1) + &
27312       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
27313
27314       gvdwx(k,i) = gvdwx(k,i) &
27315                - dPOLdR1 * hawk
27316       gvdwx(k,j) = gvdwx(k,j) &
27317                + dPOLdR1 * (erhead_tail(k,1) &
27318        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
27319
27320       gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
27321       gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
27322
27323        END DO
27324        RETURN
27325       END SUBROUTINE eqn
27326       SUBROUTINE enq(Epol)
27327       use calc_data
27328       use comm_momo
27329        double precision facd3, adler,epol
27330        alphapol2 = alphapol(itypj,itypi)
27331 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27332        R2 = 0.0d0
27333        DO k = 1, 3
27334 !c! Calculate head-to-tail distances
27335       R2=R2+(chead(k,2)-ctail(k,1))**2
27336        END DO
27337 !c! Pitagoras
27338        R2 = dsqrt(R2)
27339
27340 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27341 !c!     &        +dhead(1,1,itypi,itypj))**2))
27342 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27343 !c!     &        +dhead(2,1,itypi,itypj))**2))
27344 !c------------------------------------------------------------------------
27345 !c Polarization energy
27346        MomoFac2 = (1.0d0 - chi2 * sqom1)
27347        RR2  = R2 * R2 / MomoFac2
27348        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27349        fgb2 = sqrt(RR2  + a12sq * ee2)
27350        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27351        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27352             / (fgb2 ** 5.0d0)
27353        dFGBdR2 = ( (R2 / MomoFac2)  &
27354             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27355             / (2.0d0 * fgb2)
27356        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27357             * (2.0d0 - 0.5d0 * ee2) ) &
27358             / (2.0d0 * fgb2)
27359        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27360 !c!       dPOLdR2 = 0.0d0
27361        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27362 !c!       dPOLdOM1 = 0.0d0
27363        dPOLdOM2 = 0.0d0
27364 !c!-------------------------------------------------------------------
27365 !c! Return the results
27366 !c! (See comments in Eqq)
27367        DO k = 1, 3
27368       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27369        END DO
27370        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27371        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27372        facd2 = d2 * vbld_inv(j+nres)
27373        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27374        DO k = 1, 3
27375       condor = (erhead_tail(k,2) &
27376        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
27377
27378       gvdwx(k,i) = gvdwx(k,i) &
27379                - dPOLdR2 * (erhead_tail(k,2) &
27380        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
27381       gvdwx(k,j) = gvdwx(k,j)   &
27382                + dPOLdR2 * condor
27383
27384       gvdwc(k,i) = gvdwc(k,i) &
27385                - dPOLdR2 * erhead_tail(k,2)
27386       gvdwc(k,j) = gvdwc(k,j) &
27387                + dPOLdR2 * erhead_tail(k,2)
27388
27389        END DO
27390       RETURN
27391       END SUBROUTINE enq
27392
27393       SUBROUTINE enq_cat(Epol)
27394       use calc_data
27395       use comm_momo
27396        double precision facd3, adler,epol
27397        alphapol2 = alphapolcat(itypi,itypj)
27398 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27399        R2 = 0.0d0
27400        DO k = 1, 3
27401 !c! Calculate head-to-tail distances
27402       R2=R2+(chead(k,2)-ctail(k,1))**2
27403        END DO
27404 !c! Pitagoras
27405        R2 = dsqrt(R2)
27406
27407 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27408 !c!     &        +dhead(1,1,itypi,itypj))**2))
27409 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27410 !c!     &        +dhead(2,1,itypi,itypj))**2))
27411 !c------------------------------------------------------------------------
27412 !c Polarization energy
27413        MomoFac2 = (1.0d0 - chi2 * sqom1)
27414        RR2  = R2 * R2 / MomoFac2
27415        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27416        fgb2 = sqrt(RR2  + a12sq * ee2)
27417        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27418        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27419             / (fgb2 ** 5.0d0)
27420        dFGBdR2 = ( (R2 / MomoFac2)  &
27421             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27422             / (2.0d0 * fgb2)
27423        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27424             * (2.0d0 - 0.5d0 * ee2) ) &
27425             / (2.0d0 * fgb2)
27426        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27427 !c!       dPOLdR2 = 0.0d0
27428        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27429 !c!       dPOLdOM1 = 0.0d0
27430        dPOLdOM2 = 0.0d0
27431
27432 !c!-------------------------------------------------------------------
27433 !c! Return the results
27434 !c! (See comments in Eqq)
27435        DO k = 1, 3
27436       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27437        END DO
27438        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27439        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27440        facd2 = d2 * vbld_inv(j+nres)
27441        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
27442        DO k = 1, 3
27443       condor = (erhead_tail(k,2) &
27444        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27445
27446       gradpepcatx(k,i) = gradpepcatx(k,i) &
27447                - dPOLdR2 * (erhead_tail(k,2) &
27448        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
27449 !        gradpepcatx(k,j) = gradpepcatx(k,j)   &
27450 !                   + dPOLdR2 * condor
27451
27452       gradpepcat(k,i) = gradpepcat(k,i) &
27453                - dPOLdR2 * erhead_tail(k,2)
27454       gradpepcat(k,j) = gradpepcat(k,j) &
27455                + dPOLdR2 * erhead_tail(k,2)
27456
27457        END DO
27458       RETURN
27459       END SUBROUTINE enq_cat
27460
27461       SUBROUTINE eqd(Ecl,Elj,Epol)
27462       use calc_data
27463       use comm_momo
27464        double precision  facd4, federmaus,ecl,elj,epol
27465        alphapol1 = alphapol(itypi,itypj)
27466        w1        = wqdip(1,itypi,itypj)
27467        w2        = wqdip(2,itypi,itypj)
27468        pis       = sig0head(itypi,itypj)
27469        eps_head   = epshead(itypi,itypj)
27470 !c!-------------------------------------------------------------------
27471 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27472        R1 = 0.0d0
27473        DO k = 1, 3
27474 !c! Calculate head-to-tail distances
27475       R1=R1+(ctail(k,2)-chead(k,1))**2
27476        END DO
27477 !c! Pitagoras
27478        R1 = dsqrt(R1)
27479
27480 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27481 !c!     &        +dhead(1,1,itypi,itypj))**2))
27482 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27483 !c!     &        +dhead(2,1,itypi,itypj))**2))
27484
27485 !c!-------------------------------------------------------------------
27486 !c! ecl
27487        sparrow  = w1 * Qi * om1
27488        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
27489        Ecl = sparrow / Rhead**2.0d0 &
27490          - hawk    / Rhead**4.0d0
27491        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27492              + 4.0d0 * hawk    / Rhead**5.0d0
27493 !c! dF/dom1
27494        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
27495 !c! dF/dom2
27496        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
27497 !c--------------------------------------------------------------------
27498 !c Polarization energy
27499 !c Epol
27500        MomoFac1 = (1.0d0 - chi1 * sqom2)
27501        RR1  = R1 * R1 / MomoFac1
27502        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27503        fgb1 = sqrt( RR1 + a12sq * ee1)
27504        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
27505 !c!       epol = 0.0d0
27506 !c!------------------------------------------------------------------
27507 !c! derivative of Epol is Gpol...
27508        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
27509              / (fgb1 ** 5.0d0)
27510        dFGBdR1 = ( (R1 / MomoFac1)  &
27511            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
27512            / ( 2.0d0 * fgb1 )
27513        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
27514              * (2.0d0 - 0.5d0 * ee1) ) &
27515              / (2.0d0 * fgb1)
27516        dPOLdR1 = dPOLdFGB1 * dFGBdR1
27517 !c!       dPOLdR1 = 0.0d0
27518        dPOLdOM1 = 0.0d0
27519        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27520 !c!       dPOLdOM2 = 0.0d0
27521 !c!-------------------------------------------------------------------
27522 !c! Elj
27523        pom = (pis / Rhead)**6.0d0
27524        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27525 !c! derivative of Elj is Glj
27526        dGLJdR = 4.0d0 * eps_head &
27527         * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27528         +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27529        DO k = 1, 3
27530       erhead(k) = Rhead_distance(k)/Rhead
27531       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27532        END DO
27533
27534        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27535        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27536        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27537        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27538        facd1 = d1 * vbld_inv(i+nres)
27539        facd2 = d2 * vbld_inv(j+nres)
27540        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27541
27542        DO k = 1, 3
27543       hawk = (erhead_tail(k,1) +  &
27544       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
27545
27546       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27547       gvdwx(k,i) = gvdwx(k,i)  &
27548                - dGCLdR * pom&
27549                - dPOLdR1 * hawk &
27550                - dGLJdR * pom
27551
27552       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27553       gvdwx(k,j) = gvdwx(k,j)    &
27554                + dGCLdR * pom  &
27555                + dPOLdR1 * (erhead_tail(k,1) &
27556        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
27557                + dGLJdR * pom
27558
27559
27560       gvdwc(k,i) = gvdwc(k,i)          &
27561                - dGCLdR * erhead(k)  &
27562                - dPOLdR1 * erhead_tail(k,1) &
27563                - dGLJdR * erhead(k)
27564
27565       gvdwc(k,j) = gvdwc(k,j)          &
27566                + dGCLdR * erhead(k)  &
27567                + dPOLdR1 * erhead_tail(k,1) &
27568                + dGLJdR * erhead(k)
27569
27570        END DO
27571        RETURN
27572       END SUBROUTINE eqd
27573       SUBROUTINE edq(Ecl,Elj,Epol)
27574 !       IMPLICIT NONE
27575        use comm_momo
27576       use calc_data
27577
27578       double precision  facd3, adler,ecl,elj,epol
27579        alphapol2 = alphapol(itypj,itypi)
27580        w1        = wqdip(1,itypi,itypj)
27581        w2        = wqdip(2,itypi,itypj)
27582        pis       = sig0head(itypi,itypj)
27583        eps_head  = epshead(itypi,itypj)
27584 !c!-------------------------------------------------------------------
27585 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27586        R2 = 0.0d0
27587        DO k = 1, 3
27588 !c! Calculate head-to-tail distances
27589       R2=R2+(chead(k,2)-ctail(k,1))**2
27590        END DO
27591 !c! Pitagoras
27592        R2 = dsqrt(R2)
27593
27594 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27595 !c!     &        +dhead(1,1,itypi,itypj))**2))
27596 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27597 !c!     &        +dhead(2,1,itypi,itypj))**2))
27598
27599
27600 !c!-------------------------------------------------------------------
27601 !c! ecl
27602        sparrow  = w1 * Qj * om1
27603        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27604        ECL = sparrow / Rhead**2.0d0 &
27605          - hawk    / Rhead**4.0d0
27606 !c!-------------------------------------------------------------------
27607 !c! derivative of ecl is Gcl
27608 !c! dF/dr part
27609        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27610              + 4.0d0 * hawk    / Rhead**5.0d0
27611 !c! dF/dom1
27612        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27613 !c! dF/dom2
27614        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27615 !c--------------------------------------------------------------------
27616 !c Polarization energy
27617 !c Epol
27618        MomoFac2 = (1.0d0 - chi2 * sqom1)
27619        RR2  = R2 * R2 / MomoFac2
27620        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27621        fgb2 = sqrt(RR2  + a12sq * ee2)
27622        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27623        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27624              / (fgb2 ** 5.0d0)
27625        dFGBdR2 = ( (R2 / MomoFac2)  &
27626              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27627              / (2.0d0 * fgb2)
27628        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27629             * (2.0d0 - 0.5d0 * ee2) ) &
27630             / (2.0d0 * fgb2)
27631        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27632 !c!       dPOLdR2 = 0.0d0
27633        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27634 !c!       dPOLdOM1 = 0.0d0
27635        dPOLdOM2 = 0.0d0
27636 !c!-------------------------------------------------------------------
27637 !c! Elj
27638        pom = (pis / Rhead)**6.0d0
27639        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27640 !c! derivative of Elj is Glj
27641        dGLJdR = 4.0d0 * eps_head &
27642          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27643          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27644 !c!-------------------------------------------------------------------
27645 !c! Return the results
27646 !c! (see comments in Eqq)
27647        DO k = 1, 3
27648       erhead(k) = Rhead_distance(k)/Rhead
27649       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27650        END DO
27651        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27652        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27653        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27654        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27655        facd1 = d1 * vbld_inv(i+nres)
27656        facd2 = d2 * vbld_inv(j+nres)
27657        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27658        DO k = 1, 3
27659       condor = (erhead_tail(k,2) &
27660        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
27661
27662       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27663       gvdwx(k,i) = gvdwx(k,i) &
27664               - dGCLdR * pom &
27665               - dPOLdR2 * (erhead_tail(k,2) &
27666        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27667               - dGLJdR * pom
27668
27669       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27670       gvdwx(k,j) = gvdwx(k,j) &
27671               + dGCLdR * pom &
27672               + dPOLdR2 * condor &
27673               + dGLJdR * pom
27674
27675
27676       gvdwc(k,i) = gvdwc(k,i) &
27677               - dGCLdR * erhead(k) &
27678               - dPOLdR2 * erhead_tail(k,2) &
27679               - dGLJdR * erhead(k)
27680
27681       gvdwc(k,j) = gvdwc(k,j) &
27682               + dGCLdR * erhead(k) &
27683               + dPOLdR2 * erhead_tail(k,2) &
27684               + dGLJdR * erhead(k)
27685
27686        END DO
27687        RETURN
27688       END SUBROUTINE edq
27689
27690       SUBROUTINE edq_cat(Ecl,Elj,Epol)
27691       use comm_momo
27692       use calc_data
27693
27694       double precision  facd3, adler,ecl,elj,epol
27695        alphapol2 = alphapolcat(itypi,itypj)
27696        w1        = wqdipcat(1,itypi,itypj)
27697        w2        = wqdipcat(2,itypi,itypj)
27698        pis       = sig0headcat(itypi,itypj)
27699        eps_head  = epsheadcat(itypi,itypj)
27700 !c!-------------------------------------------------------------------
27701 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27702        R2 = 0.0d0
27703        DO k = 1, 3
27704 !c! Calculate head-to-tail distances
27705       R2=R2+(chead(k,2)-ctail(k,1))**2
27706        END DO
27707 !c! Pitagoras
27708        R2 = dsqrt(R2)
27709
27710 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27711 !c!     &        +dhead(1,1,itypi,itypj))**2))
27712 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27713 !c!     &        +dhead(2,1,itypi,itypj))**2))
27714
27715
27716 !c!-------------------------------------------------------------------
27717 !c! ecl
27718 !       write(iout,*) "KURWA2",Rhead
27719        sparrow  = w1 * Qj * om1
27720        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27721        ECL = sparrow / Rhead**2.0d0 &
27722          - hawk    / Rhead**4.0d0
27723 !c!-------------------------------------------------------------------
27724 !c! derivative of ecl is Gcl
27725 !c! dF/dr part
27726        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27727              + 4.0d0 * hawk    / Rhead**5.0d0
27728 !c! dF/dom1
27729        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27730 !c! dF/dom2
27731        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27732 !c--------------------------------------------------------------------
27733 !c--------------------------------------------------------------------
27734 !c Polarization energy
27735 !c Epol
27736        MomoFac2 = (1.0d0 - chi2 * sqom1)
27737        RR2  = R2 * R2 / MomoFac2
27738        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27739        fgb2 = sqrt(RR2  + a12sq * ee2)
27740        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27741        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27742              / (fgb2 ** 5.0d0)
27743        dFGBdR2 = ( (R2 / MomoFac2)  &
27744              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27745              / (2.0d0 * fgb2)
27746        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27747             * (2.0d0 - 0.5d0 * ee2) ) &
27748             / (2.0d0 * fgb2)
27749        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27750 !c!       dPOLdR2 = 0.0d0
27751        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27752 !c!       dPOLdOM1 = 0.0d0
27753        dPOLdOM2 = 0.0d0
27754 !c!-------------------------------------------------------------------
27755 !c! Elj
27756        pom = (pis / Rhead)**6.0d0
27757        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27758 !c! derivative of Elj is Glj
27759        dGLJdR = 4.0d0 * eps_head &
27760          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27761          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27762 !c!-------------------------------------------------------------------
27763
27764 !c! Return the results
27765 !c! (see comments in Eqq)
27766        DO k = 1, 3
27767       erhead(k) = Rhead_distance(k)/Rhead
27768       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27769        END DO
27770        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27771        erdxj = scalar( erhead(1), dC_norm(1,j) )
27772        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27773        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27774        facd1 = d1 * vbld_inv(i+nres)
27775        facd2 = d2 * vbld_inv(j)
27776        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
27777        DO k = 1, 3
27778       condor = (erhead_tail(k,2) &
27779        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27780
27781       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27782       gradpepcatx(k,i) = gradpepcatx(k,i) &
27783               - dGCLdR * pom &
27784               - dPOLdR2 * (erhead_tail(k,2) &
27785        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27786               - dGLJdR * pom
27787
27788       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27789 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
27790 !                  + dGCLdR * pom &
27791 !                  + dPOLdR2 * condor &
27792 !                  + dGLJdR * pom
27793
27794
27795       gradpepcat(k,i) = gradpepcat(k,i) &
27796               - dGCLdR * erhead(k) &
27797               - dPOLdR2 * erhead_tail(k,2) &
27798               - dGLJdR * erhead(k)
27799
27800       gradpepcat(k,j) = gradpepcat(k,j) &
27801               + dGCLdR * erhead(k) &
27802               + dPOLdR2 * erhead_tail(k,2) &
27803               + dGLJdR * erhead(k)
27804
27805        END DO
27806        RETURN
27807       END SUBROUTINE edq_cat
27808
27809       SUBROUTINE edq_cat_pep(Ecl,Elj,Epol)
27810       use comm_momo
27811       use calc_data
27812
27813       double precision  facd3, adler,ecl,elj,epol
27814        alphapol2 = alphapolcat(itypi,itypj)
27815        w1        = wqdipcat(1,itypi,itypj)
27816        w2        = wqdipcat(2,itypi,itypj)
27817        pis       = sig0headcat(itypi,itypj)
27818        eps_head  = epsheadcat(itypi,itypj)
27819 !c!-------------------------------------------------------------------
27820 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27821        R2 = 0.0d0
27822        DO k = 1, 3
27823 !c! Calculate head-to-tail distances
27824       R2=R2+(chead(k,2)-ctail(k,1))**2
27825        END DO
27826 !c! Pitagoras
27827        R2 = dsqrt(R2)
27828
27829 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27830 !c!     &        +dhead(1,1,itypi,itypj))**2))
27831 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27832 !c!     &        +dhead(2,1,itypi,itypj))**2))
27833
27834
27835 !c!-------------------------------------------------------------------
27836 !c! ecl
27837        sparrow  = w1 * Qj * om1
27838        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27839 !       print *,"CO2", itypi,itypj
27840 !       print *,"CO?!.", w1,w2,Qj,om1
27841        ECL = sparrow / Rhead**2.0d0 &
27842          - hawk    / Rhead**4.0d0
27843 !c!-------------------------------------------------------------------
27844 !c! derivative of ecl is Gcl
27845 !c! dF/dr part
27846        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27847              + 4.0d0 * hawk    / Rhead**5.0d0
27848 !c! dF/dom1
27849        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27850 !c! dF/dom2
27851        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27852 !c--------------------------------------------------------------------
27853 !c--------------------------------------------------------------------
27854 !c Polarization energy
27855 !c Epol
27856        MomoFac2 = (1.0d0 - chi2 * sqom1)
27857        RR2  = R2 * R2 / MomoFac2
27858        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27859        fgb2 = sqrt(RR2  + a12sq * ee2)
27860        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27861        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27862              / (fgb2 ** 5.0d0)
27863        dFGBdR2 = ( (R2 / MomoFac2)  &
27864              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27865              / (2.0d0 * fgb2)
27866        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27867             * (2.0d0 - 0.5d0 * ee2) ) &
27868             / (2.0d0 * fgb2)
27869        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27870 !c!       dPOLdR2 = 0.0d0
27871        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27872 !c!       dPOLdOM1 = 0.0d0
27873        dPOLdOM2 = 0.0d0
27874 !c!-------------------------------------------------------------------
27875 !c! Elj
27876        pom = (pis / Rhead)**6.0d0
27877        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27878 !c! derivative of Elj is Glj
27879        dGLJdR = 4.0d0 * eps_head &
27880          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27881          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27882 !c!-------------------------------------------------------------------
27883
27884 !c! Return the results
27885 !c! (see comments in Eqq)
27886        DO k = 1, 3
27887       erhead(k) = Rhead_distance(k)/Rhead
27888       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27889        END DO
27890        erdxi = scalar( erhead(1), dC_norm(1,i) )
27891        erdxj = scalar( erhead(1), dC_norm(1,j) )
27892        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27893        adler = scalar( erhead_tail(1,2), dC_norm(1,i) )
27894        facd1 = d1 * vbld_inv(i+1)/2.0
27895        facd2 = d2 * vbld_inv(j)
27896        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+1)/2.0
27897        DO k = 1, 3
27898       condor = (erhead_tail(k,2) &
27899        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27900
27901       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i))
27902 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
27903 !                  - dGCLdR * pom &
27904 !                  - dPOLdR2 * (erhead_tail(k,2) &
27905 !       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27906 !                  - dGLJdR * pom
27907
27908       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27909 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
27910 !                  + dGCLdR * pom &
27911 !                  + dPOLdR2 * condor &
27912 !                  + dGLJdR * pom
27913
27914
27915       gradpepcat(k,i) = gradpepcat(k,i) +0.5d0*( &
27916               - dGCLdR * erhead(k) &
27917               - dPOLdR2 * erhead_tail(k,2) &
27918               - dGLJdR * erhead(k))
27919       gradpepcat(k,i+1) = gradpepcat(k,i+1) +0.5d0*( &
27920               - dGCLdR * erhead(k) &
27921               - dPOLdR2 * erhead_tail(k,2) &
27922               - dGLJdR * erhead(k))
27923
27924
27925       gradpepcat(k,j) = gradpepcat(k,j) &
27926               + dGCLdR * erhead(k) &
27927               + dPOLdR2 * erhead_tail(k,2) &
27928               + dGLJdR * erhead(k)
27929
27930        END DO
27931        RETURN
27932       END SUBROUTINE edq_cat_pep
27933
27934       SUBROUTINE edd(ECL)
27935 !       IMPLICIT NONE
27936        use comm_momo
27937       use calc_data
27938
27939        double precision ecl
27940 !c!       csig = sigiso(itypi,itypj)
27941        w1 = wqdip(1,itypi,itypj)
27942        w2 = wqdip(2,itypi,itypj)
27943 !c!-------------------------------------------------------------------
27944 !c! ECL
27945        fac = (om12 - 3.0d0 * om1 * om2)
27946        c1 = (w1 / (Rhead**3.0d0)) * fac
27947        c2 = (w2 / Rhead ** 6.0d0) &
27948         * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27949        ECL = c1 - c2
27950 !c!       write (*,*) "w1 = ", w1
27951 !c!       write (*,*) "w2 = ", w2
27952 !c!       write (*,*) "om1 = ", om1
27953 !c!       write (*,*) "om2 = ", om2
27954 !c!       write (*,*) "om12 = ", om12
27955 !c!       write (*,*) "fac = ", fac
27956 !c!       write (*,*) "c1 = ", c1
27957 !c!       write (*,*) "c2 = ", c2
27958 !c!       write (*,*) "Ecl = ", Ecl
27959 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
27960 !c!       write (*,*) "c2_2 = ",
27961 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27962 !c!-------------------------------------------------------------------
27963 !c! dervative of ECL is GCL...
27964 !c! dECL/dr
27965        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
27966        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
27967         * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
27968        dGCLdR = c1 - c2
27969 !c! dECL/dom1
27970        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
27971        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27972         * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
27973        dGCLdOM1 = c1 - c2
27974 !c! dECL/dom2
27975        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
27976        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27977         * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
27978        dGCLdOM2 = c1 - c2
27979 !c! dECL/dom12
27980        c1 = w1 / (Rhead ** 3.0d0)
27981        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
27982        dGCLdOM12 = c1 - c2
27983 !c!-------------------------------------------------------------------
27984 !c! Return the results
27985 !c! (see comments in Eqq)
27986        DO k= 1, 3
27987       erhead(k) = Rhead_distance(k)/Rhead
27988        END DO
27989        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27990        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27991        facd1 = d1 * vbld_inv(i+nres)
27992        facd2 = d2 * vbld_inv(j+nres)
27993        DO k = 1, 3
27994
27995       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27996       gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
27997       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27998       gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
27999
28000       gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
28001       gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
28002        END DO
28003        RETURN
28004       END SUBROUTINE edd
28005       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
28006 !       IMPLICIT NONE
28007        use comm_momo
28008       use calc_data
28009
28010        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
28011        eps_out=80.0d0
28012        itypi = itype(i,1)
28013        itypj = itype(j,1)
28014 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
28015 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
28016 !c!       t_bath = 300
28017 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
28018        Rb=0.001986d0
28019        BetaT = 1.0d0 / (298.0d0 * Rb)
28020 !c! Gay-berne var's
28021        sig0ij = sigma( itypi,itypj )
28022        chi1   = chi( itypi, itypj )
28023        chi2   = chi( itypj, itypi )
28024        chi12  = chi1 * chi2
28025        chip1  = chipp( itypi, itypj )
28026        chip2  = chipp( itypj, itypi )
28027        chip12 = chip1 * chip2
28028 !       chi1=0.0
28029 !       chi2=0.0
28030 !       chi12=0.0
28031 !       chip1=0.0
28032 !       chip2=0.0
28033 !       chip12=0.0
28034 !c! not used by momo potential, but needed by sc_angular which is shared
28035 !c! by all energy_potential subroutines
28036        alf1   = 0.0d0
28037        alf2   = 0.0d0
28038        alf12  = 0.0d0
28039 !c! location, location, location
28040 !       xj  = c( 1, nres+j ) - xi
28041 !       yj  = c( 2, nres+j ) - yi
28042 !       zj  = c( 3, nres+j ) - zi
28043        dxj = dc_norm( 1, nres+j )
28044        dyj = dc_norm( 2, nres+j )
28045        dzj = dc_norm( 3, nres+j )
28046 !c! distance from center of chain(?) to polar/charged head
28047 !c!       write (*,*) "istate = ", 1
28048 !c!       write (*,*) "ii = ", 1
28049 !c!       write (*,*) "jj = ", 1
28050        d1 = dhead(1, 1, itypi, itypj)
28051        d2 = dhead(2, 1, itypi, itypj)
28052 !c! ai*aj from Fgb
28053        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
28054 !c!       a12sq = a12sq * a12sq
28055 !c! charge of amino acid itypi is...
28056        Qi  = icharge(itypi)
28057        Qj  = icharge(itypj)
28058        Qij = Qi * Qj
28059 !c! chis1,2,12
28060        chis1 = chis(itypi,itypj)
28061        chis2 = chis(itypj,itypi)
28062        chis12 = chis1 * chis2
28063        sig1 = sigmap1(itypi,itypj)
28064        sig2 = sigmap2(itypi,itypj)
28065 !c!       write (*,*) "sig1 = ", sig1
28066 !c!       write (*,*) "sig2 = ", sig2
28067 !c! alpha factors from Fcav/Gcav
28068        b1cav = alphasur(1,itypi,itypj)
28069 !       b1cav=0.0
28070        b2cav = alphasur(2,itypi,itypj)
28071        b3cav = alphasur(3,itypi,itypj)
28072        b4cav = alphasur(4,itypi,itypj)
28073        wqd = wquad(itypi, itypj)
28074 !c! used by Fgb
28075        eps_in = epsintab(itypi,itypj)
28076        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
28077 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
28078 !c!-------------------------------------------------------------------
28079 !c! tail location and distance calculations
28080        Rtail = 0.0d0
28081        DO k = 1, 3
28082       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
28083       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
28084        END DO
28085 !c! tail distances will be themselves usefull elswhere
28086 !c1 (in Gcav, for example)
28087        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
28088        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
28089        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
28090        Rtail = dsqrt(  &
28091         (Rtail_distance(1)*Rtail_distance(1))  &
28092       + (Rtail_distance(2)*Rtail_distance(2))  &
28093       + (Rtail_distance(3)*Rtail_distance(3)))
28094 !c!-------------------------------------------------------------------
28095 !c! Calculate location and distance between polar heads
28096 !c! distance between heads
28097 !c! for each one of our three dimensional space...
28098        d1 = dhead(1, 1, itypi, itypj)
28099        d2 = dhead(2, 1, itypi, itypj)
28100
28101        DO k = 1,3
28102 !c! location of polar head is computed by taking hydrophobic centre
28103 !c! and moving by a d1 * dc_norm vector
28104 !c! see unres publications for very informative images
28105       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
28106       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
28107 !c! distance
28108 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
28109 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
28110       Rhead_distance(k) = chead(k,2) - chead(k,1)
28111        END DO
28112 !c! pitagoras (root of sum of squares)
28113        Rhead = dsqrt(   &
28114         (Rhead_distance(1)*Rhead_distance(1)) &
28115       + (Rhead_distance(2)*Rhead_distance(2)) &
28116       + (Rhead_distance(3)*Rhead_distance(3)))
28117 !c!-------------------------------------------------------------------
28118 !c! zero everything that should be zero'ed
28119        Egb = 0.0d0
28120        ECL = 0.0d0
28121        Elj = 0.0d0
28122        Equad = 0.0d0
28123        Epol = 0.0d0
28124        eheadtail = 0.0d0
28125        dGCLdOM1 = 0.0d0
28126        dGCLdOM2 = 0.0d0
28127        dGCLdOM12 = 0.0d0
28128        dPOLdOM1 = 0.0d0
28129        dPOLdOM2 = 0.0d0
28130        RETURN
28131       END SUBROUTINE elgrad_init
28132
28133
28134       SUBROUTINE elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
28135       use comm_momo
28136       use calc_data
28137        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
28138        eps_out=80.0d0
28139        itypi = itype(i,1)
28140        itypj = itype(j,5)
28141 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
28142 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
28143 !c!       t_bath = 300
28144 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
28145        Rb=0.001986d0
28146        BetaT = 1.0d0 / (298.0d0 * Rb)
28147 !c! Gay-berne var's
28148        sig0ij = sigmacat( itypi,itypj )
28149        chi1   = chi1cat( itypi, itypj )
28150        chi2   = 0.0d0
28151        chi12  = 0.0d0
28152        chip1  = chipp1cat( itypi, itypj )
28153        chip2  = 0.0d0
28154        chip12 = 0.0d0
28155 !c! not used by momo potential, but needed by sc_angular which is shared
28156 !c! by all energy_potential subroutines
28157        alf1   = 0.0d0
28158        alf2   = 0.0d0
28159        alf12  = 0.0d0
28160        dxj = 0.0d0 !dc_norm( 1, nres+j )
28161        dyj = 0.0d0 !dc_norm( 2, nres+j )
28162        dzj = 0.0d0 !dc_norm( 3, nres+j )
28163 !c! distance from center of chain(?) to polar/charged head
28164        d1 = dheadcat(1, 1, itypi, itypj)
28165        d2 = dheadcat(2, 1, itypi, itypj)
28166 !c! ai*aj from Fgb
28167        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
28168 !c!       a12sq = a12sq * a12sq
28169 !c! charge of amino acid itypi is...
28170        Qi  = icharge(itypi)
28171        Qj  = ichargecat(itypj)
28172        Qij = Qi * Qj
28173 !c! chis1,2,12
28174        chis1 = chis1cat(itypi,itypj)
28175        chis2 = 0.0d0
28176        chis12 = 0.0d0
28177        sig1 = sigmap1cat(itypi,itypj)
28178        sig2 = sigmap2cat(itypi,itypj)
28179 !c! alpha factors from Fcav/Gcav
28180        b1cav = alphasurcat(1,itypi,itypj)
28181        b2cav = alphasurcat(2,itypi,itypj)
28182        b3cav = alphasurcat(3,itypi,itypj)
28183        b4cav = alphasurcat(4,itypi,itypj)
28184        wqd = wquadcat(itypi, itypj)
28185 !c! used by Fgb
28186        eps_in = epsintabcat(itypi,itypj)
28187        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
28188 !c!-------------------------------------------------------------------
28189 !c! tail location and distance calculations
28190        Rtail = 0.0d0
28191        DO k = 1, 3
28192       ctail(k,1)=c(k,i+nres)-dtailcat(1,itypi,itypj)*dc_norm(k,nres+i)
28193       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
28194        END DO
28195 !c! tail distances will be themselves usefull elswhere
28196 !c1 (in Gcav, for example)
28197        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
28198        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
28199        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
28200        Rtail = dsqrt(  &
28201         (Rtail_distance(1)*Rtail_distance(1))  &
28202       + (Rtail_distance(2)*Rtail_distance(2))  &
28203       + (Rtail_distance(3)*Rtail_distance(3)))
28204 !c!-------------------------------------------------------------------
28205 !c! Calculate location and distance between polar heads
28206 !c! distance between heads
28207 !c! for each one of our three dimensional space...
28208        d1 = dheadcat(1, 1, itypi, itypj)
28209        d2 = dheadcat(2, 1, itypi, itypj)
28210
28211        DO k = 1,3
28212 !c! location of polar head is computed by taking hydrophobic centre
28213 !c! and moving by a d1 * dc_norm vector
28214 !c! see unres publications for very informative images
28215       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
28216       chead(k,2) = c(k, j)
28217 !c! distance
28218 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
28219 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
28220       Rhead_distance(k) = chead(k,2) - chead(k,1)
28221        END DO
28222 !c! pitagoras (root of sum of squares)
28223        Rhead = dsqrt(   &
28224         (Rhead_distance(1)*Rhead_distance(1)) &
28225       + (Rhead_distance(2)*Rhead_distance(2)) &
28226       + (Rhead_distance(3)*Rhead_distance(3)))
28227 !c!-------------------------------------------------------------------
28228 !c! zero everything that should be zero'ed
28229        Egb = 0.0d0
28230        ECL = 0.0d0
28231        Elj = 0.0d0
28232        Equad = 0.0d0
28233        Epol = 0.0d0
28234        eheadtail = 0.0d0
28235        dGCLdOM1 = 0.0d0
28236        dGCLdOM2 = 0.0d0
28237        dGCLdOM12 = 0.0d0
28238        dPOLdOM1 = 0.0d0
28239        dPOLdOM2 = 0.0d0
28240        RETURN
28241       END SUBROUTINE elgrad_init_cat
28242
28243       SUBROUTINE elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
28244       use comm_momo
28245       use calc_data
28246        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
28247        eps_out=80.0d0
28248        itypi = 10
28249        itypj = itype(j,5)
28250 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
28251 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
28252 !c!       t_bath = 300
28253 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
28254        Rb=0.001986d0
28255        BetaT = 1.0d0 / (298.0d0 * Rb)
28256 !c! Gay-berne var's
28257        sig0ij = sigmacat( itypi,itypj )
28258        chi1   = chi1cat( itypi, itypj )
28259        chi2   = 0.0d0
28260        chi12  = 0.0d0
28261        chip1  = chipp1cat( itypi, itypj )
28262        chip2  = 0.0d0
28263        chip12 = 0.0d0
28264 !c! not used by momo potential, but needed by sc_angular which is shared
28265 !c! by all energy_potential subroutines
28266        alf1   = 0.0d0
28267        alf2   = 0.0d0
28268        alf12  = 0.0d0
28269        dxj = 0.0d0 !dc_norm( 1, nres+j )
28270        dyj = 0.0d0 !dc_norm( 2, nres+j )
28271        dzj = 0.0d0 !dc_norm( 3, nres+j )
28272 !c! distance from center of chain(?) to polar/charged head
28273        d1 = dheadcat(1, 1, itypi, itypj)
28274        d2 = dheadcat(2, 1, itypi, itypj)
28275 !c! ai*aj from Fgb
28276        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
28277 !c!       a12sq = a12sq * a12sq
28278 !c! charge of amino acid itypi is...
28279        Qi  = 0
28280        Qj  = ichargecat(itypj)
28281 !       Qij = Qi * Qj
28282 !c! chis1,2,12
28283        chis1 = chis1cat(itypi,itypj)
28284        chis2 = 0.0d0
28285        chis12 = 0.0d0
28286        sig1 = sigmap1cat(itypi,itypj)
28287        sig2 = sigmap2cat(itypi,itypj)
28288 !c! alpha factors from Fcav/Gcav
28289        b1cav = alphasurcat(1,itypi,itypj)
28290        b2cav = alphasurcat(2,itypi,itypj)
28291        b3cav = alphasurcat(3,itypi,itypj)
28292        b4cav = alphasurcat(4,itypi,itypj)
28293        wqd = wquadcat(itypi, itypj)
28294 !c! used by Fgb
28295        eps_in = epsintabcat(itypi,itypj)
28296        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
28297 !c!-------------------------------------------------------------------
28298 !c! tail location and distance calculations
28299        Rtail = 0.0d0
28300        DO k = 1, 3
28301       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0-dtailcat(1,itypi,itypj)*dc_norm(k,i)
28302       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
28303        END DO
28304 !c! tail distances will be themselves usefull elswhere
28305 !c1 (in Gcav, for example)
28306        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
28307        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
28308        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
28309        Rtail = dsqrt(  &
28310         (Rtail_distance(1)*Rtail_distance(1))  &
28311       + (Rtail_distance(2)*Rtail_distance(2))  &
28312       + (Rtail_distance(3)*Rtail_distance(3)))
28313 !c!-------------------------------------------------------------------
28314 !c! Calculate location and distance between polar heads
28315 !c! distance between heads
28316 !c! for each one of our three dimensional space...
28317        d1 = dheadcat(1, 1, itypi, itypj)
28318        d2 = dheadcat(2, 1, itypi, itypj)
28319
28320        DO k = 1,3
28321 !c! location of polar head is computed by taking hydrophobic centre
28322 !c! and moving by a d1 * dc_norm vector
28323 !c! see unres publications for very informative images
28324       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
28325       chead(k,2) = c(k, j)
28326 !c! distance
28327 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
28328 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
28329       Rhead_distance(k) = chead(k,2) - chead(k,1)
28330        END DO
28331 !c! pitagoras (root of sum of squares)
28332        Rhead = dsqrt(   &
28333         (Rhead_distance(1)*Rhead_distance(1)) &
28334       + (Rhead_distance(2)*Rhead_distance(2)) &
28335       + (Rhead_distance(3)*Rhead_distance(3)))
28336 !c!-------------------------------------------------------------------
28337 !c! zero everything that should be zero'ed
28338        Egb = 0.0d0
28339        ECL = 0.0d0
28340        Elj = 0.0d0
28341        Equad = 0.0d0
28342        Epol = 0.0d0
28343        eheadtail = 0.0d0
28344        dGCLdOM1 = 0.0d0
28345        dGCLdOM2 = 0.0d0
28346        dGCLdOM12 = 0.0d0
28347        dPOLdOM1 = 0.0d0
28348        dPOLdOM2 = 0.0d0
28349        RETURN
28350       END SUBROUTINE elgrad_init_cat_pep
28351
28352       double precision function tschebyshev(m,n,x,y)
28353       implicit none
28354       integer i,m,n
28355       double precision x(n),y,yy(0:maxvar),aux
28356 !c Tschebyshev polynomial. Note that the first term is omitted
28357 !c m=0: the constant term is included
28358 !c m=1: the constant term is not included
28359       yy(0)=1.0d0
28360       yy(1)=y
28361       do i=2,n
28362       yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
28363       enddo
28364       aux=0.0d0
28365       do i=m,n
28366       aux=aux+x(i)*yy(i)
28367       enddo
28368       tschebyshev=aux
28369       return
28370       end function tschebyshev
28371 !C--------------------------------------------------------------------------
28372       double precision function gradtschebyshev(m,n,x,y)
28373       implicit none
28374       integer i,m,n
28375       double precision x(n+1),y,yy(0:maxvar),aux
28376 !c Tschebyshev polynomial. Note that the first term is omitted
28377 !c m=0: the constant term is included
28378 !c m=1: the constant term is not included
28379       yy(0)=1.0d0
28380       yy(1)=2.0d0*y
28381       do i=2,n
28382       yy(i)=2*y*yy(i-1)-yy(i-2)
28383       enddo
28384       aux=0.0d0
28385       do i=m,n
28386       aux=aux+x(i+1)*yy(i)*(i+1)
28387 !C        print *, x(i+1),yy(i),i
28388       enddo
28389       gradtschebyshev=aux
28390       return
28391       end function gradtschebyshev
28392
28393       subroutine make_SCSC_inter_list
28394       include 'mpif.h'
28395       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
28396       real*8 :: dist_init, dist_temp,r_buff_list
28397       integer:: contlisti(250*nres),contlistj(250*nres)
28398 !      integer :: newcontlisti(200*nres),newcontlistj(200*nres)
28399       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_sc,g_ilist_sc
28400       integer displ(0:nprocs),i_ilist_sc(0:nprocs),ierr
28401 !            print *,"START make_SC"
28402         r_buff_list=5.0
28403           ilist_sc=0
28404           do i=iatsc_s,iatsc_e
28405            itypi=iabs(itype(i,1))
28406            if (itypi.eq.ntyp1) cycle
28407            xi=c(1,nres+i)
28408            yi=c(2,nres+i)
28409            zi=c(3,nres+i)
28410           call to_box(xi,yi,zi)
28411            do iint=1,nint_gr(i)
28412 !           print *,"is it wrong", iint,i
28413             do j=istart(i,iint),iend(i,iint)
28414              itypj=iabs(itype(j,1))
28415              if (energy_dec) write(iout,*) "LISTA ZAKRES",istart(i,iint),iend(i,iint),iatsc_s,iatsc_e
28416              if (itypj.eq.ntyp1) cycle
28417              xj=c(1,nres+j)
28418              yj=c(2,nres+j)
28419              zj=c(3,nres+j)
28420              call to_box(xj,yj,zj)
28421 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
28422 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
28423           xj=boxshift(xj-xi,boxxsize)
28424           yj=boxshift(yj-yi,boxysize)
28425           zj=boxshift(zj-zi,boxzsize)
28426           dist_init=xj**2+yj**2+zj**2
28427 !             dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
28428 ! r_buff_list is a read value for a buffer
28429              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
28430 ! Here the list is created
28431              ilist_sc=ilist_sc+1
28432 ! this can be substituted by cantor and anti-cantor
28433              contlisti(ilist_sc)=i
28434              contlistj(ilist_sc)=j
28435
28436              endif
28437            enddo
28438            enddo
28439            enddo
28440 !         call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
28441 !          MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
28442 !        call MPI_Gather(newnss,1,MPI_INTEGER,&
28443 !                        i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
28444 #ifdef DEBUG
28445       write (iout,*) "before MPIREDUCE",ilist_sc
28446       do i=1,ilist_sc
28447       write (iout,*) i,contlisti(i),contlistj(i)
28448       enddo
28449 #endif
28450       if (nfgtasks.gt.1)then
28451
28452       call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
28453         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
28454 !        write(iout,*) "before bcast",g_ilist_sc
28455       call MPI_Gather(ilist_sc,1,MPI_INTEGER,&
28456                   i_ilist_sc,1,MPI_INTEGER,king,FG_COMM,IERR)
28457       displ(0)=0
28458       do i=1,nfgtasks-1,1
28459         displ(i)=i_ilist_sc(i-1)+displ(i-1)
28460       enddo
28461 !        write(iout,*) "before gather",displ(0),displ(1)
28462       call MPI_Gatherv(contlisti,ilist_sc,MPI_INTEGER,&
28463                    newcontlisti,i_ilist_sc,displ,MPI_INTEGER,&
28464                    king,FG_COMM,IERR)
28465       call MPI_Gatherv(contlistj,ilist_sc,MPI_INTEGER,&
28466                    newcontlistj,i_ilist_sc,displ,MPI_INTEGER,&
28467                    king,FG_COMM,IERR)
28468       call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM,IERR)
28469 !        write(iout,*) "before bcast",g_ilist_sc
28470 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28471       call MPI_Bcast(newcontlisti,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
28472       call MPI_Bcast(newcontlistj,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
28473
28474 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28475
28476       else
28477       g_ilist_sc=ilist_sc
28478
28479       do i=1,ilist_sc
28480       newcontlisti(i)=contlisti(i)
28481       newcontlistj(i)=contlistj(i)
28482       enddo
28483       endif
28484
28485 #ifdef DEBUG
28486       write (iout,*) "after MPIREDUCE",g_ilist_sc
28487       do i=1,g_ilist_sc
28488       write (iout,*) i,newcontlisti(i),newcontlistj(i)
28489       enddo
28490 #endif
28491       call int_bounds(g_ilist_sc,g_listscsc_start,g_listscsc_end)
28492       return
28493       end subroutine make_SCSC_inter_list
28494 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
28495
28496       subroutine make_SCp_inter_list
28497       use MD_data,  only: itime_mat
28498
28499       include 'mpif.h'
28500       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
28501       real*8 :: dist_init, dist_temp,r_buff_list
28502       integer:: contlistscpi(350*nres),contlistscpj(350*nres)
28503 !      integer :: newcontlistscpi(200*nres),newcontlistscpj(200*nres)
28504       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_scp,g_ilist_scp
28505       integer displ(0:nprocs),i_ilist_scp(0:nprocs),ierr
28506 !            print *,"START make_SC"
28507       r_buff_list=5.0
28508           ilist_scp=0
28509       do i=iatscp_s,iatscp_e
28510       if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
28511       xi=0.5D0*(c(1,i)+c(1,i+1))
28512       yi=0.5D0*(c(2,i)+c(2,i+1))
28513       zi=0.5D0*(c(3,i)+c(3,i+1))
28514         call to_box(xi,yi,zi)
28515       do iint=1,nscp_gr(i)
28516
28517       do j=iscpstart(i,iint),iscpend(i,iint)
28518         itypj=iabs(itype(j,1))
28519         if (itypj.eq.ntyp1) cycle
28520 ! Uncomment following three lines for SC-p interactions
28521 !         xj=c(1,nres+j)-xi
28522 !         yj=c(2,nres+j)-yi
28523 !         zj=c(3,nres+j)-zi
28524 ! Uncomment following three lines for Ca-p interactions
28525 !          xj=c(1,j)-xi
28526 !          yj=c(2,j)-yi
28527 !          zj=c(3,j)-zi
28528         xj=c(1,j)
28529         yj=c(2,j)
28530         zj=c(3,j)
28531         call to_box(xj,yj,zj)
28532       xj=boxshift(xj-xi,boxxsize)
28533       yj=boxshift(yj-yi,boxysize)
28534       zj=boxshift(zj-zi,boxzsize)
28535       dist_init=xj**2+yj**2+zj**2
28536 #ifdef DEBUG
28537             ! r_buff_list is a read value for a buffer
28538              if ((sqrt(dist_init).le.(r_cut_ele)).and.(ifirstrun.eq.0)) then
28539 ! Here the list is created
28540              ilist_scp_first=ilist_scp_first+1
28541 ! this can be substituted by cantor and anti-cantor
28542              contlistscpi_f(ilist_scp_first)=i
28543              contlistscpj_f(ilist_scp_first)=j
28544             endif
28545 #endif
28546 ! r_buff_list is a read value for a buffer
28547              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
28548 ! Here the list is created
28549              ilist_scp=ilist_scp+1
28550 ! this can be substituted by cantor and anti-cantor
28551              contlistscpi(ilist_scp)=i
28552              contlistscpj(ilist_scp)=j
28553             endif
28554            enddo
28555            enddo
28556            enddo
28557 #ifdef DEBUG
28558       write (iout,*) "before MPIREDUCE",ilist_scp
28559       do i=1,ilist_scp
28560       write (iout,*) i,contlistscpi(i),contlistscpj(i)
28561       enddo
28562 #endif
28563       if (nfgtasks.gt.1)then
28564
28565       call MPI_Reduce(ilist_scp,g_ilist_scp,1,&
28566         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
28567 !        write(iout,*) "before bcast",g_ilist_sc
28568       call MPI_Gather(ilist_scp,1,MPI_INTEGER,&
28569                   i_ilist_scp,1,MPI_INTEGER,king,FG_COMM,IERR)
28570       displ(0)=0
28571       do i=1,nfgtasks-1,1
28572         displ(i)=i_ilist_scp(i-1)+displ(i-1)
28573       enddo
28574 !        write(iout,*) "before gather",displ(0),displ(1)
28575       call MPI_Gatherv(contlistscpi,ilist_scp,MPI_INTEGER,&
28576                    newcontlistscpi,i_ilist_scp,displ,MPI_INTEGER,&
28577                    king,FG_COMM,IERR)
28578       call MPI_Gatherv(contlistscpj,ilist_scp,MPI_INTEGER,&
28579                    newcontlistscpj,i_ilist_scp,displ,MPI_INTEGER,&
28580                    king,FG_COMM,IERR)
28581       call MPI_Bcast(g_ilist_scp,1,MPI_INT,king,FG_COMM,IERR)
28582 !        write(iout,*) "before bcast",g_ilist_sc
28583 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28584       call MPI_Bcast(newcontlistscpi,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
28585       call MPI_Bcast(newcontlistscpj,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
28586
28587 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28588
28589       else
28590       g_ilist_scp=ilist_scp
28591
28592       do i=1,ilist_scp
28593       newcontlistscpi(i)=contlistscpi(i)
28594       newcontlistscpj(i)=contlistscpj(i)
28595       enddo
28596       endif
28597
28598 #ifdef DEBUG
28599       write (iout,*) "after MPIREDUCE",g_ilist_scp
28600       do i=1,g_ilist_scp
28601       write (iout,*) i,newcontlistscpi(i),newcontlistscpj(i)
28602       enddo
28603
28604 !      if (ifirstrun.eq.0) ifirstrun=1
28605 !      do i=1,ilist_scp_first
28606 !       do j=1,g_ilist_scp
28607 !        if ((newcontlistscpi(j).eq.contlistscpi_f(i)).and.&
28608 !         (newcontlistscpj(j).eq.contlistscpj_f(i))) go to 126
28609 !        enddo
28610 !       print *,itime_mat,"ERROR matrix needs updating"
28611 !       print *,contlistscpi_f(i),contlistscpj_f(i)
28612 !  126  continue
28613 !      enddo
28614 #endif
28615       call int_bounds(g_ilist_scp,g_listscp_start,g_listscp_end)
28616
28617       return
28618       end subroutine make_SCp_inter_list
28619
28620 !-----------------------------------------------------------------------------
28621 !-----------------------------------------------------------------------------
28622
28623
28624       subroutine make_pp_inter_list
28625       include 'mpif.h'
28626       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
28627       real*8 :: xmedj,ymedj,zmedj,sslipi,ssgradlipi,faclipij2,sslipj,ssgradlipj
28628       real*8 :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi
28629       real*8 :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj
28630       integer:: contlistppi(250*nres),contlistppj(250*nres)
28631 !      integer :: newcontlistppi(200*nres),newcontlistppj(200*nres)
28632       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_pp,g_ilist_pp
28633       integer displ(0:nprocs),i_ilist_pp(0:nprocs),ierr
28634 !            write(iout,*),"START make_pp",iatel_s,iatel_e,r_cut_ele+r_buff_list
28635             ilist_pp=0
28636       r_buff_list=5.0
28637       do i=iatel_s,iatel_e
28638         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
28639         dxi=dc(1,i)
28640         dyi=dc(2,i)
28641         dzi=dc(3,i)
28642         dx_normi=dc_norm(1,i)
28643         dy_normi=dc_norm(2,i)
28644         dz_normi=dc_norm(3,i)
28645         xmedi=c(1,i)+0.5d0*dxi
28646         ymedi=c(2,i)+0.5d0*dyi
28647         zmedi=c(3,i)+0.5d0*dzi
28648
28649         call to_box(xmedi,ymedi,zmedi)
28650         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
28651 !          write (iout,*) i,j,itype(i,1),itype(j,1)
28652 !          if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
28653
28654 ! 1,j)
28655              do j=ielstart(i),ielend(i)
28656 !          write (iout,*) i,j,itype(i,1),itype(j,1)
28657           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
28658           dxj=dc(1,j)
28659           dyj=dc(2,j)
28660           dzj=dc(3,j)
28661           dx_normj=dc_norm(1,j)
28662           dy_normj=dc_norm(2,j)
28663           dz_normj=dc_norm(3,j)
28664 !          xj=c(1,j)+0.5D0*dxj-xmedi
28665 !          yj=c(2,j)+0.5D0*dyj-ymedi
28666 !          zj=c(3,j)+0.5D0*dzj-zmedi
28667           xj=c(1,j)+0.5D0*dxj
28668           yj=c(2,j)+0.5D0*dyj
28669           zj=c(3,j)+0.5D0*dzj
28670           call to_box(xj,yj,zj)
28671 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
28672 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
28673           xj=boxshift(xj-xmedi,boxxsize)
28674           yj=boxshift(yj-ymedi,boxysize)
28675           zj=boxshift(zj-zmedi,boxzsize)
28676           dist_init=xj**2+yj**2+zj**2
28677       if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
28678 ! Here the list is created
28679                  ilist_pp=ilist_pp+1
28680 ! this can be substituted by cantor and anti-cantor
28681                  contlistppi(ilist_pp)=i
28682                  contlistppj(ilist_pp)=j
28683               endif
28684 !             enddo
28685              enddo
28686              enddo
28687 #ifdef DEBUG
28688       write (iout,*) "before MPIREDUCE",ilist_pp
28689       do i=1,ilist_pp
28690       write (iout,*) i,contlistppi(i),contlistppj(i)
28691       enddo
28692 #endif
28693       if (nfgtasks.gt.1)then
28694
28695         call MPI_Reduce(ilist_pp,g_ilist_pp,1,&
28696           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
28697 !        write(iout,*) "before bcast",g_ilist_sc
28698         call MPI_Gather(ilist_pp,1,MPI_INTEGER,&
28699                         i_ilist_pp,1,MPI_INTEGER,king,FG_COMM,IERR)
28700         displ(0)=0
28701         do i=1,nfgtasks-1,1
28702           displ(i)=i_ilist_pp(i-1)+displ(i-1)
28703         enddo
28704 !        write(iout,*) "before gather",displ(0),displ(1)
28705         call MPI_Gatherv(contlistppi,ilist_pp,MPI_INTEGER,&
28706                          newcontlistppi,i_ilist_pp,displ,MPI_INTEGER,&
28707                          king,FG_COMM,IERR)
28708         call MPI_Gatherv(contlistppj,ilist_pp,MPI_INTEGER,&
28709                          newcontlistppj,i_ilist_pp,displ,MPI_INTEGER,&
28710                          king,FG_COMM,IERR)
28711         call MPI_Bcast(g_ilist_pp,1,MPI_INT,king,FG_COMM,IERR)
28712 !        write(iout,*) "before bcast",g_ilist_sc
28713 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28714         call MPI_Bcast(newcontlistppi,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
28715         call MPI_Bcast(newcontlistppj,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
28716
28717 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28718
28719         else
28720         g_ilist_pp=ilist_pp
28721
28722         do i=1,ilist_pp
28723         newcontlistppi(i)=contlistppi(i)
28724         newcontlistppj(i)=contlistppj(i)
28725         enddo
28726         endif
28727         call int_bounds(g_ilist_pp,g_listpp_start,g_listpp_end)
28728 #ifdef DEBUG
28729       write (iout,*) "after MPIREDUCE",g_ilist_pp
28730       do i=1,g_ilist_pp
28731       write (iout,*) i,newcontlistppi(i),newcontlistppj(i)
28732       enddo
28733 #endif
28734       return
28735       end subroutine make_pp_inter_list
28736
28737 !-----------------------------------------------------------------------------
28738       double precision function boxshift(x,boxsize)
28739       implicit none
28740       double precision x,boxsize
28741       double precision xtemp
28742       xtemp=dmod(x,boxsize)
28743       if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
28744         boxshift=xtemp-boxsize
28745       else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
28746         boxshift=xtemp+boxsize
28747       else
28748         boxshift=xtemp
28749       endif
28750       return
28751       end function boxshift
28752 !-----------------------------------------------------------------------------
28753       subroutine to_box(xi,yi,zi)
28754       implicit none
28755 !      include 'DIMENSIONS'
28756 !      include 'COMMON.CHAIN'
28757       double precision xi,yi,zi
28758       xi=dmod(xi,boxxsize)
28759       if (xi.lt.0.0d0) xi=xi+boxxsize
28760       yi=dmod(yi,boxysize)
28761       if (yi.lt.0.0d0) yi=yi+boxysize
28762       zi=dmod(zi,boxzsize)
28763       if (zi.lt.0.0d0) zi=zi+boxzsize
28764       return
28765       end subroutine to_box
28766 !--------------------------------------------------------------------------
28767       subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
28768       implicit none
28769 !      include 'DIMENSIONS'
28770 !      include 'COMMON.IOUNITS'
28771 !      include 'COMMON.CHAIN'
28772       double precision xi,yi,zi,sslipi,ssgradlipi
28773       double precision fracinbuf
28774 !      double precision sscalelip,sscagradlip
28775 #ifdef DEBUG
28776       write (iout,*) "bordlipbot",bordlipbot," bordliptop",bordliptop
28777       write (iout,*) "buflipbot",buflipbot," lipbufthick",lipbufthick
28778       write (iout,*) "xi yi zi",xi,yi,zi
28779 #endif
28780       if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
28781 ! the energy transfer exist
28782         if (zi.lt.buflipbot) then
28783 ! what fraction I am in
28784           fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
28785 ! lipbufthick is thickenes of lipid buffore
28786           sslipi=sscalelip(fracinbuf)
28787           ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
28788         elseif (zi.gt.bufliptop) then
28789           fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
28790           sslipi=sscalelip(fracinbuf)
28791           ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
28792         else
28793           sslipi=1.0d0
28794           ssgradlipi=0.0
28795         endif
28796       else
28797         sslipi=0.0d0
28798         ssgradlipi=0.0
28799       endif
28800 #ifdef DEBUG
28801       write (iout,*) "sslipi",sslipi," ssgradlipi",ssgradlipi
28802 #endif
28803       return
28804       end subroutine lipid_layer
28805
28806 !--------------------------------------------------------------------------
28807 !--------------------------------------------------------------------------
28808       end module energy