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+ehomology_constr  &
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 #else
1129       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
1130        +wang*ebe+wtor*etors+wscloc*escloc &
1131        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1132        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1133        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1134        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1135        +Eafmforce+ethetacnstr+ehomology_constr &
1136        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1137        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1138        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1139        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1140        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1141        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho+wcatnucl*ecation_nucl
1142 #endif
1143       energia(0)=etot
1144 ! detecting NaNQ
1145 #ifdef ISNAN
1146 #ifdef AIX
1147       if (isnan(etot).ne.0) energia(0)=1.0d+99
1148 #else
1149       if (isnan(etot)) energia(0)=1.0d+99
1150 #endif
1151 #else
1152       i=0
1153 #ifdef WINPGI
1154       idumm=proc_proc(etot,i)
1155 #else
1156       call proc_proc(etot,i)
1157 #endif
1158       if(i.eq.1)energia(0)=1.0d+99
1159 #endif
1160 #ifdef MPI
1161       endif
1162 #endif
1163 !      call enerprint(energia)
1164       call flush(iout)
1165       return
1166       end subroutine sum_energy
1167 !-----------------------------------------------------------------------------
1168       subroutine rescale_weights(t_bath)
1169 !      implicit real*8 (a-h,o-z)
1170 #ifdef MPI
1171       include 'mpif.h'
1172 #endif
1173 !      include 'DIMENSIONS'
1174 !      include 'COMMON.IOUNITS'
1175 !      include 'COMMON.FFIELD'
1176 !      include 'COMMON.SBRIDGE'
1177       real(kind=8) :: kfac=2.4d0
1178       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
1179 !el local variables
1180       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
1181       real(kind=8) :: T0=3.0d2
1182       integer :: ierror
1183 !      facT=temp0/t_bath
1184 !      facT=2*temp0/(t_bath+temp0)
1185       if (rescale_mode.eq.0) then
1186         facT(1)=1.0d0
1187         facT(2)=1.0d0
1188         facT(3)=1.0d0
1189         facT(4)=1.0d0
1190         facT(5)=1.0d0
1191         facT(6)=1.0d0
1192       else if (rescale_mode.eq.1) then
1193         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
1194         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1195         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1196         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1197         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1198 #ifdef WHAM_RUN
1199 !#if defined(WHAM_RUN) || defined(CLUSTER)
1200 #if defined(FUNCTH)
1201 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
1202         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1203 #elif defined(FUNCT)
1204         facT(6)=t_bath/T0
1205 #else
1206         facT(6)=1.0d0
1207 #endif
1208 #endif
1209       else if (rescale_mode.eq.2) then
1210         x=t_bath/temp0
1211         x2=x*x
1212         x3=x2*x
1213         x4=x3*x
1214         x5=x4*x
1215         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
1216         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
1217         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
1218         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
1219         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
1220 #ifdef WHAM_RUN
1221 !#if defined(WHAM_RUN) || defined(CLUSTER)
1222 #if defined(FUNCTH)
1223         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1224 #elif defined(FUNCT)
1225         facT(6)=t_bath/T0
1226 #else
1227         facT(6)=1.0d0
1228 #endif
1229 #endif
1230       else
1231         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1232         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1233 #ifdef MPI
1234        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1235 #endif
1236        stop 555
1237       endif
1238       welec=weights(3)*fact(1)
1239       wcorr=weights(4)*fact(3)
1240       wcorr5=weights(5)*fact(4)
1241       wcorr6=weights(6)*fact(5)
1242       wel_loc=weights(7)*fact(2)
1243       wturn3=weights(8)*fact(2)
1244       wturn4=weights(9)*fact(3)
1245       wturn6=weights(10)*fact(5)
1246       wtor=weights(13)*fact(1)
1247       wtor_d=weights(14)*fact(2)
1248       wsccor=weights(21)*fact(1)
1249       welpsb=weights(28)*fact(1)
1250       wcorr_nucl= weights(37)*fact(1)
1251       wcorr3_nucl=weights(38)*fact(2)
1252       wtor_nucl=  weights(35)*fact(1)
1253       wtor_d_nucl=weights(36)*fact(2)
1254       wpepbase=weights(47)*fact(1)
1255       return
1256       end subroutine rescale_weights
1257 !-----------------------------------------------------------------------------
1258       subroutine enerprint(energia)
1259 !      implicit real*8 (a-h,o-z)
1260 !      include 'DIMENSIONS'
1261 !      include 'COMMON.IOUNITS'
1262 !      include 'COMMON.FFIELD'
1263 !      include 'COMMON.SBRIDGE'
1264 !      include 'COMMON.MD'
1265       real(kind=8) :: energia(0:n_ene)
1266 !el local variables
1267       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
1268       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
1269       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
1270        etube,ethetacnstr,Eafmforce
1271       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1272                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1273                       ecorr3_nucl,ehomology_constr
1274       real(kind=8) :: ecation_prot,ecationcation,ecations_prot_amber,&
1275                       ecation_nucl
1276       real(kind=8) :: escbase,epepbase,escpho,epeppho
1277
1278       etot=energia(0)
1279       evdw=energia(1)
1280       evdw2=energia(2)
1281 #ifdef SCP14
1282       evdw2=energia(2)+energia(18)
1283 #else
1284       evdw2=energia(2)
1285 #endif
1286       ees=energia(3)
1287 #ifdef SPLITELE
1288       evdw1=energia(16)
1289 #endif
1290       ecorr=energia(4)
1291       ecorr5=energia(5)
1292       ecorr6=energia(6)
1293       eel_loc=energia(7)
1294       eello_turn3=energia(8)
1295       eello_turn4=energia(9)
1296       eello_turn6=energia(10)
1297       ebe=energia(11)
1298       escloc=energia(12)
1299       etors=energia(13)
1300       etors_d=energia(14)
1301       ehpb=energia(15)
1302       edihcnstr=energia(19)
1303       estr=energia(17)
1304       Uconst=energia(20)
1305       esccor=energia(21)
1306       eliptran=energia(22)
1307       Eafmforce=energia(23)
1308       ethetacnstr=energia(24)
1309       etube=energia(25)
1310       evdwpp=energia(26)
1311       eespp=energia(27)
1312       evdwpsb=energia(28)
1313       eelpsb=energia(29)
1314       evdwsb=energia(30)
1315       eelsb=energia(31)
1316       estr_nucl=energia(32)
1317       ebe_nucl=energia(33)
1318       esbloc=energia(34)
1319       etors_nucl=energia(35)
1320       etors_d_nucl=energia(36)
1321       ecorr_nucl=energia(37)
1322       ecorr3_nucl=energia(38)
1323       ecation_prot=energia(42)
1324       ecationcation=energia(41)
1325       escbase=energia(46)
1326       epepbase=energia(47)
1327       escpho=energia(48)
1328       epeppho=energia(49)
1329       ecation_nucl=energia(50)
1330       ehomology_constr=energia(51)
1331
1332 !      ecations_prot_amber=energia(50)
1333 #ifdef SPLITELE
1334       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1335         estr,wbond,ebe,wang,&
1336         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1337         ecorr,wcorr,&
1338         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1339         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1340         edihcnstr,ethetacnstr,ebr*nss,&
1341         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1342         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1343         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1344         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1345         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1346         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1347         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1348         ecation_nucl,wcatnucl,ehomology_constr,etot
1349    10 format (/'Virtual-chain energies:'// &
1350        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1351        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1352        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1353        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1354        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1355        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1356        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1357        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1358        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1359        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1360        ' (SS bridges & dist. cnstr.)'/ &
1361        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1362        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1363        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1364        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1365        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1366        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1367        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1368        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1369        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1370        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1371        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1372        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1373        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1374        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1375        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1376        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1377        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1378        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1379        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1380        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1381        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1382        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1383        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1384        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1385        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1386        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1387        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1388        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1389        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1390        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1391        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1392        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1393        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1394        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1395        'ECATBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(cation nucl-base)'/&
1396        'H_CONS=',1pE16.6,' (Homology model constraints energy)'/&
1397        'ETOT=  ',1pE16.6,' (total)')
1398 #else
1399       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1400         estr,wbond,ebe,wang,&
1401         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1402         ecorr,wcorr,&
1403         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1404         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1405         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforce,     &
1406         etube,wtube, ehomology_constr,&
1407         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1408         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1409         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1410         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1411         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1412         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1413         ecation_nucl,wcatnucl,ehomology_constr,etot
1414    10 format (/'Virtual-chain energies:'// &
1415        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1416        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1417        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1418        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1419        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1420        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1421        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1422        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1423        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1424        ' (SS bridges & dist. cnstr.)'/ &
1425        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1426        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1427        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1428        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1429        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1430        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1431        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1432        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1433        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1434        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1435        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1436        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1437        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1438        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1439        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1440        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1441        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1442        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1443        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1444        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1445        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1446        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1447        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1448        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1449        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1450        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1451        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1452        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1453        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1454        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1455        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1456        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1457        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1458        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1459        'ECATBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(cation nucl-base)'/&
1460        'H_CONS=',1pE16.6,' (Homology model constraints energy)'/&
1461        'ETOT=  ',1pE16.6,' (total)')
1462 #endif
1463       return
1464       end subroutine enerprint
1465 !-----------------------------------------------------------------------------
1466       subroutine elj(evdw)
1467 !
1468 ! This subroutine calculates the interaction energy of nonbonded side chains
1469 ! assuming the LJ potential of interaction.
1470 !
1471 !      implicit real*8 (a-h,o-z)
1472 !      include 'DIMENSIONS'
1473       real(kind=8),parameter :: accur=1.0d-10
1474 !      include 'COMMON.GEO'
1475 !      include 'COMMON.VAR'
1476 !      include 'COMMON.LOCAL'
1477 !      include 'COMMON.CHAIN'
1478 !      include 'COMMON.DERIV'
1479 !      include 'COMMON.INTERACT'
1480 !      include 'COMMON.TORSION'
1481 !      include 'COMMON.SBRIDGE'
1482 !      include 'COMMON.NAMES'
1483 !      include 'COMMON.IOUNITS'
1484 !      include 'COMMON.CONTACTS'
1485       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1486       integer :: num_conti
1487 !el local variables
1488       integer :: i,itypi,iint,j,itypi1,itypj,k
1489       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij,sslipi,ssgradlipi,&
1490        aa,bb,sslipj,ssgradlipj
1491       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1492       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1493
1494 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1495       evdw=0.0D0
1496 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1497 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1498 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1499 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1500
1501       do i=iatsc_s,iatsc_e
1502         itypi=iabs(itype(i,1))
1503         if (itypi.eq.ntyp1) cycle
1504         itypi1=iabs(itype(i+1,1))
1505         xi=c(1,nres+i)
1506         yi=c(2,nres+i)
1507         zi=c(3,nres+i)
1508         call to_box(xi,yi,zi)
1509         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1510
1511 ! Change 12/1/95
1512         num_conti=0
1513 !
1514 ! Calculate SC interaction energy.
1515 !
1516         do iint=1,nint_gr(i)
1517 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1518 !d   &                  'iend=',iend(i,iint)
1519           do j=istart(i,iint),iend(i,iint)
1520             itypj=iabs(itype(j,1))
1521             if (itypj.eq.ntyp1) cycle
1522             xj=c(1,nres+j)-xi
1523             yj=c(2,nres+j)-yi
1524             zj=c(3,nres+j)-zi
1525             call to_box(xj,yj,zj)
1526             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1527             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1528              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1529             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1530              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1531             xj=boxshift(xj-xi,boxxsize)
1532             yj=boxshift(yj-yi,boxysize)
1533             zj=boxshift(zj-zi,boxzsize)
1534 ! Change 12/1/95 to calculate four-body interactions
1535             rij=xj*xj+yj*yj+zj*zj
1536             rrij=1.0D0/rij
1537 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1538             eps0ij=eps(itypi,itypj)
1539             fac=rrij**expon2
1540             e1=fac*fac*aa_aq(itypi,itypj)
1541             e2=fac*bb_aq(itypi,itypj)
1542             evdwij=e1+e2
1543 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1544 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1545 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1546 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1547 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1548 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1549             evdw=evdw+evdwij
1550 !
1551 ! Calculate the components of the gradient in DC and X
1552 !
1553             fac=-rrij*(e1+evdwij)
1554             gg(1)=xj*fac
1555             gg(2)=yj*fac
1556             gg(3)=zj*fac
1557             do k=1,3
1558               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1559               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1560               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1561               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1562             enddo
1563 !grad            do k=i,j-1
1564 !grad              do l=1,3
1565 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1566 !grad              enddo
1567 !grad            enddo
1568 !
1569 ! 12/1/95, revised on 5/20/97
1570 !
1571 ! Calculate the contact function. The ith column of the array JCONT will
1572 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1573 ! greater than I). The arrays FACONT and GACONT will contain the values of
1574 ! the contact function and its derivative.
1575 !
1576 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1577 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1578 ! Uncomment next line, if the correlation interactions are contact function only
1579             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1580               rij=dsqrt(rij)
1581               sigij=sigma(itypi,itypj)
1582               r0ij=rs0(itypi,itypj)
1583 !
1584 ! Check whether the SC's are not too far to make a contact.
1585 !
1586               rcut=1.5d0*r0ij
1587               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1588 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1589 !
1590               if (fcont.gt.0.0D0) then
1591 ! If the SC-SC distance if close to sigma, apply spline.
1592 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1593 !Adam &             fcont1,fprimcont1)
1594 !Adam           fcont1=1.0d0-fcont1
1595 !Adam           if (fcont1.gt.0.0d0) then
1596 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1597 !Adam             fcont=fcont*fcont1
1598 !Adam           endif
1599 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1600 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1601 !ga             do k=1,3
1602 !ga               gg(k)=gg(k)*eps0ij
1603 !ga             enddo
1604 !ga             eps0ij=-evdwij*eps0ij
1605 ! Uncomment for AL's type of SC correlation interactions.
1606 !adam           eps0ij=-evdwij
1607                 num_conti=num_conti+1
1608                 jcont(num_conti,i)=j
1609                 facont(num_conti,i)=fcont*eps0ij
1610                 fprimcont=eps0ij*fprimcont/rij
1611                 fcont=expon*fcont
1612 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1613 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1614 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1615 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1616                 gacont(1,num_conti,i)=-fprimcont*xj
1617                 gacont(2,num_conti,i)=-fprimcont*yj
1618                 gacont(3,num_conti,i)=-fprimcont*zj
1619 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1620 !d              write (iout,'(2i3,3f10.5)')
1621 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1622               endif
1623             endif
1624           enddo      ! j
1625         enddo        ! iint
1626 ! Change 12/1/95
1627         num_cont(i)=num_conti
1628       enddo          ! i
1629       do i=1,nct
1630         do j=1,3
1631           gvdwc(j,i)=expon*gvdwc(j,i)
1632           gvdwx(j,i)=expon*gvdwx(j,i)
1633         enddo
1634       enddo
1635 !******************************************************************************
1636 !
1637 !                              N O T E !!!
1638 !
1639 ! To save time, the factor of EXPON has been extracted from ALL components
1640 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1641 ! use!
1642 !
1643 !******************************************************************************
1644       return
1645       end subroutine elj
1646 !-----------------------------------------------------------------------------
1647       subroutine eljk(evdw)
1648 !
1649 ! This subroutine calculates the interaction energy of nonbonded side chains
1650 ! assuming the LJK potential of interaction.
1651 !
1652 !      implicit real*8 (a-h,o-z)
1653 !      include 'DIMENSIONS'
1654 !      include 'COMMON.GEO'
1655 !      include 'COMMON.VAR'
1656 !      include 'COMMON.LOCAL'
1657 !      include 'COMMON.CHAIN'
1658 !      include 'COMMON.DERIV'
1659 !      include 'COMMON.INTERACT'
1660 !      include 'COMMON.IOUNITS'
1661 !      include 'COMMON.NAMES'
1662       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1663       logical :: scheck
1664 !el local variables
1665       integer :: i,iint,j,itypi,itypi1,k,itypj
1666       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij, &
1667          sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb
1668       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1669
1670 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1671       evdw=0.0D0
1672       do i=iatsc_s,iatsc_e
1673         itypi=iabs(itype(i,1))
1674         if (itypi.eq.ntyp1) cycle
1675         itypi1=iabs(itype(i+1,1))
1676         xi=c(1,nres+i)
1677         yi=c(2,nres+i)
1678         zi=c(3,nres+i)
1679         call to_box(xi,yi,zi)
1680         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1681
1682 !
1683 ! Calculate SC interaction energy.
1684 !
1685         do iint=1,nint_gr(i)
1686           do j=istart(i,iint),iend(i,iint)
1687             itypj=iabs(itype(j,1))
1688             if (itypj.eq.ntyp1) cycle
1689             xj=c(1,nres+j)-xi
1690             yj=c(2,nres+j)-yi
1691             zj=c(3,nres+j)-zi
1692             call to_box(xj,yj,zj)
1693             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1694             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1695              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1696             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1697              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1698             xj=boxshift(xj-xi,boxxsize)
1699             yj=boxshift(yj-yi,boxysize)
1700             zj=boxshift(zj-zi,boxzsize)
1701             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1702             fac_augm=rrij**expon
1703             e_augm=augm(itypi,itypj)*fac_augm
1704             r_inv_ij=dsqrt(rrij)
1705             rij=1.0D0/r_inv_ij
1706             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1707             fac=r_shift_inv**expon
1708             e1=fac*fac*aa_aq(itypi,itypj)
1709             e2=fac*bb_aq(itypi,itypj)
1710             evdwij=e_augm+e1+e2
1711 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1712 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1713 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1714 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1715 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1716 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1717 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1718             evdw=evdw+evdwij
1719 !
1720 ! Calculate the components of the gradient in DC and X
1721 !
1722             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1723             gg(1)=xj*fac
1724             gg(2)=yj*fac
1725             gg(3)=zj*fac
1726             do k=1,3
1727               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1728               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1729               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1730               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1731             enddo
1732 !grad            do k=i,j-1
1733 !grad              do l=1,3
1734 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1735 !grad              enddo
1736 !grad            enddo
1737           enddo      ! j
1738         enddo        ! iint
1739       enddo          ! i
1740       do i=1,nct
1741         do j=1,3
1742           gvdwc(j,i)=expon*gvdwc(j,i)
1743           gvdwx(j,i)=expon*gvdwx(j,i)
1744         enddo
1745       enddo
1746       return
1747       end subroutine eljk
1748 !-----------------------------------------------------------------------------
1749       subroutine ebp(evdw)
1750 !
1751 ! This subroutine calculates the interaction energy of nonbonded side chains
1752 ! assuming the Berne-Pechukas potential of interaction.
1753 !
1754       use comm_srutu
1755       use calc_data
1756 !      implicit real*8 (a-h,o-z)
1757 !      include 'DIMENSIONS'
1758 !      include 'COMMON.GEO'
1759 !      include 'COMMON.VAR'
1760 !      include 'COMMON.LOCAL'
1761 !      include 'COMMON.CHAIN'
1762 !      include 'COMMON.DERIV'
1763 !      include 'COMMON.NAMES'
1764 !      include 'COMMON.INTERACT'
1765 !      include 'COMMON.IOUNITS'
1766 !      include 'COMMON.CALC'
1767       use comm_srutu
1768 !el      integer :: icall
1769 !el      common /srutu/ icall
1770 !     double precision rrsave(maxdim)
1771       logical :: lprn
1772 !el local variables
1773       integer :: iint,itypi,itypi1,itypj
1774       real(kind=8) :: rrij,xi,yi,zi, sslipi,ssgradlipi, sslipj, &
1775         ssgradlipj, aa, bb
1776       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1777
1778 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1779       evdw=0.0D0
1780 !     if (icall.eq.0) then
1781 !       lprn=.true.
1782 !     else
1783         lprn=.false.
1784 !     endif
1785 !el      ind=0
1786       do i=iatsc_s,iatsc_e
1787         itypi=iabs(itype(i,1))
1788         if (itypi.eq.ntyp1) cycle
1789         itypi1=iabs(itype(i+1,1))
1790         xi=c(1,nres+i)
1791         yi=c(2,nres+i)
1792         zi=c(3,nres+i)
1793         call to_box(xi,yi,zi)
1794         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1795         dxi=dc_norm(1,nres+i)
1796         dyi=dc_norm(2,nres+i)
1797         dzi=dc_norm(3,nres+i)
1798 !        dsci_inv=dsc_inv(itypi)
1799         dsci_inv=vbld_inv(i+nres)
1800 !
1801 ! Calculate SC interaction energy.
1802 !
1803         do iint=1,nint_gr(i)
1804           do j=istart(i,iint),iend(i,iint)
1805 !el            ind=ind+1
1806             itypj=iabs(itype(j,1))
1807             if (itypj.eq.ntyp1) cycle
1808 !            dscj_inv=dsc_inv(itypj)
1809             dscj_inv=vbld_inv(j+nres)
1810             chi1=chi(itypi,itypj)
1811             chi2=chi(itypj,itypi)
1812             chi12=chi1*chi2
1813             chip1=chip(itypi)
1814             chip2=chip(itypj)
1815             chip12=chip1*chip2
1816             alf1=alp(itypi)
1817             alf2=alp(itypj)
1818             alf12=0.5D0*(alf1+alf2)
1819 ! For diagnostics only!!!
1820 !           chi1=0.0D0
1821 !           chi2=0.0D0
1822 !           chi12=0.0D0
1823 !           chip1=0.0D0
1824 !           chip2=0.0D0
1825 !           chip12=0.0D0
1826 !           alf1=0.0D0
1827 !           alf2=0.0D0
1828 !           alf12=0.0D0
1829             xj=c(1,nres+j)-xi
1830             yj=c(2,nres+j)-yi
1831             zj=c(3,nres+j)-zi
1832             call to_box(xj,yj,zj)
1833             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
1834             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1835              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1836             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
1837              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1838             xj=boxshift(xj-xi,boxxsize)
1839             yj=boxshift(yj-yi,boxysize)
1840             zj=boxshift(zj-zi,boxzsize)
1841             dxj=dc_norm(1,nres+j)
1842             dyj=dc_norm(2,nres+j)
1843             dzj=dc_norm(3,nres+j)
1844             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1845 !d          if (icall.eq.0) then
1846 !d            rrsave(ind)=rrij
1847 !d          else
1848 !d            rrij=rrsave(ind)
1849 !d          endif
1850             rij=dsqrt(rrij)
1851 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1852             call sc_angular
1853 ! Calculate whole angle-dependent part of epsilon and contributions
1854 ! to its derivatives
1855             fac=(rrij*sigsq)**expon2
1856             e1=fac*fac*aa_aq(itypi,itypj)
1857             e2=fac*bb_aq(itypi,itypj)
1858             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1859             eps2der=evdwij*eps3rt
1860             eps3der=evdwij*eps2rt
1861             evdwij=evdwij*eps2rt*eps3rt
1862             evdw=evdw+evdwij
1863             if (lprn) then
1864             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1865             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1866 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1867 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1868 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1869 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1870 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1871 !d     &        evdwij
1872             endif
1873 ! Calculate gradient components.
1874             e1=e1*eps1*eps2rt**2*eps3rt**2
1875             fac=-expon*(e1+evdwij)
1876             sigder=fac/sigsq
1877             fac=rrij*fac
1878 ! Calculate radial part of the gradient
1879             gg(1)=xj*fac
1880             gg(2)=yj*fac
1881             gg(3)=zj*fac
1882 ! Calculate the angular part of the gradient and sum add the contributions
1883 ! to the appropriate components of the Cartesian gradient.
1884             call sc_grad
1885           enddo      ! j
1886         enddo        ! iint
1887       enddo          ! i
1888 !     stop
1889       return
1890       end subroutine ebp
1891 !-----------------------------------------------------------------------------
1892       subroutine egb(evdw)
1893 !
1894 ! This subroutine calculates the interaction energy of nonbonded side chains
1895 ! assuming the Gay-Berne potential of interaction.
1896 !
1897       use calc_data
1898 !      implicit real*8 (a-h,o-z)
1899 !      include 'DIMENSIONS'
1900 !      include 'COMMON.GEO'
1901 !      include 'COMMON.VAR'
1902 !      include 'COMMON.LOCAL'
1903 !      include 'COMMON.CHAIN'
1904 !      include 'COMMON.DERIV'
1905 !      include 'COMMON.NAMES'
1906 !      include 'COMMON.INTERACT'
1907 !      include 'COMMON.IOUNITS'
1908 !      include 'COMMON.CALC'
1909 !      include 'COMMON.CONTROL'
1910 !      include 'COMMON.SBRIDGE'
1911       logical :: lprn
1912 !el local variables
1913       integer :: iint,itypi,itypi1,itypj,subchap,icont
1914       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1915       real(kind=8) :: evdw,sig0ij
1916       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1917                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1918                     sslipi,sslipj,faclip
1919       integer :: ii
1920       real(kind=8) :: fracinbuf
1921
1922 !cccc      energy_dec=.false.
1923 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1924       evdw=0.0D0
1925       lprn=.false.
1926 !     if (icall.eq.0) lprn=.false.
1927 !el      ind=0
1928       dCAVdOM2=0.0d0
1929       dGCLdOM2=0.0d0
1930       dPOLdOM2=0.0d0
1931       dCAVdOM1=0.0d0
1932       dGCLdOM1=0.0d0
1933       dPOLdOM1=0.0d0
1934 !             write (iout,*) "RWA", g_listscsc_start,g_listscsc_end,i,j
1935       if (nres_molec(1).eq.0) return
1936       do icont=g_listscsc_start,g_listscsc_end
1937       i=newcontlisti(icont)
1938       j=newcontlistj(icont)
1939 !      write (iout,*) "RWA", g_listscsc_start,g_listscsc_end,i,j
1940 !      do i=iatsc_s,iatsc_e
1941 !C        print *,"I am in EVDW",i
1942         itypi=iabs(itype(i,1))
1943 !        if (i.ne.47) cycle
1944         if (itypi.eq.ntyp1) cycle
1945         itypi1=iabs(itype(i+1,1))
1946         xi=c(1,nres+i)
1947         yi=c(2,nres+i)
1948         zi=c(3,nres+i)
1949         call to_box(xi,yi,zi)
1950         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
1951
1952         dxi=dc_norm(1,nres+i)
1953         dyi=dc_norm(2,nres+i)
1954         dzi=dc_norm(3,nres+i)
1955 !        dsci_inv=dsc_inv(itypi)
1956         dsci_inv=vbld_inv(i+nres)
1957 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1958 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1959 !
1960 ! Calculate SC interaction energy.
1961 !
1962 !        do iint=1,nint_gr(i)
1963 !          do j=istart(i,iint),iend(i,iint)
1964             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1965               call dyn_ssbond_ene(i,j,evdwij)
1966               evdw=evdw+evdwij
1967               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1968                               'evdw',i,j,evdwij,' ss'
1969 !              if (energy_dec) write (iout,*) &
1970 !                              'evdw',i,j,evdwij,' ss'
1971              do k=j+1,nres
1972 !C search over all next residues
1973               if (dyn_ss_mask(k)) then
1974 !C check if they are cysteins
1975 !C              write(iout,*) 'k=',k
1976
1977 !c              write(iout,*) "PRZED TRI", evdwij
1978 !               evdwij_przed_tri=evdwij
1979               call triple_ssbond_ene(i,j,k,evdwij)
1980 !c               if(evdwij_przed_tri.ne.evdwij) then
1981 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1982 !c               endif
1983
1984 !c              write(iout,*) "PO TRI", evdwij
1985 !C call the energy function that removes the artifical triple disulfide
1986 !C bond the soubroutine is located in ssMD.F
1987               evdw=evdw+evdwij
1988               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1989                             'evdw',i,j,evdwij,'tss'
1990               endif!dyn_ss_mask(k)
1991              enddo! k
1992             ELSE
1993 !el            ind=ind+1
1994             itypj=iabs(itype(j,1))
1995             if (itypj.eq.ntyp1) cycle
1996 !             if (j.ne.78) cycle
1997 !            dscj_inv=dsc_inv(itypj)
1998             dscj_inv=vbld_inv(j+nres)
1999 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
2000 !              1.0d0/vbld(j+nres) !d
2001 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
2002             sig0ij=sigma(itypi,itypj)
2003             chi1=chi(itypi,itypj)
2004             chi2=chi(itypj,itypi)
2005             chi12=chi1*chi2
2006             chip1=chip(itypi)
2007             chip2=chip(itypj)
2008             chip12=chip1*chip2
2009             alf1=alp(itypi)
2010             alf2=alp(itypj)
2011             alf12=0.5D0*(alf1+alf2)
2012 ! For diagnostics only!!!
2013 !           chi1=0.0D0
2014 !           chi2=0.0D0
2015 !           chi12=0.0D0
2016 !           chip1=0.0D0
2017 !           chip2=0.0D0
2018 !           chip12=0.0D0
2019 !           alf1=0.0D0
2020 !           alf2=0.0D0
2021 !           alf12=0.0D0
2022            xj=c(1,nres+j)
2023            yj=c(2,nres+j)
2024            zj=c(3,nres+j)
2025               call to_box(xj,yj,zj)
2026               call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2027 !              write (iout,*) "KWA2", itypi,itypj
2028               aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2029                +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2030               bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2031                +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2032               xj=boxshift(xj-xi,boxxsize)
2033               yj=boxshift(yj-yi,boxysize)
2034               zj=boxshift(zj-zi,boxzsize)
2035             dxj=dc_norm(1,nres+j)
2036             dyj=dc_norm(2,nres+j)
2037             dzj=dc_norm(3,nres+j)
2038 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
2039 !            write (iout,*) "j",j," dc_norm",& !d
2040 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
2041 !          write(iout,*)"rrij ",rrij
2042 !          write(iout,*)"xj yj zj ", xj, yj, zj
2043 !          write(iout,*)"xi yi zi ", xi, yi, zi
2044 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
2045             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2046             rij=dsqrt(rrij)
2047             sss_ele_cut=sscale_ele(1.0d0/(rij))
2048             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
2049 !            print *,sss_ele_cut,sss_ele_grad,&
2050 !            1.0d0/(rij),r_cut_ele,rlamb_ele
2051             if (sss_ele_cut.le.0.0) cycle
2052 ! Calculate angle-dependent terms of energy and contributions to their
2053 ! derivatives.
2054             call sc_angular
2055             sigsq=1.0D0/sigsq
2056             sig=sig0ij*dsqrt(sigsq)
2057             rij_shift=1.0D0/rij-sig+sig0ij
2058 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
2059 !            "sig0ij",sig0ij
2060 ! for diagnostics; uncomment
2061 !            rij_shift=1.2*sig0ij
2062 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2063             if (rij_shift.le.0.0D0) then
2064               evdw=1.0D20
2065 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2066 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
2067 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2068               return
2069             endif
2070             sigder=-sig*sigsq
2071 !---------------------------------------------------------------
2072             rij_shift=1.0D0/rij_shift
2073             fac=rij_shift**expon
2074             faclip=fac
2075             e1=fac*fac*aa!(itypi,itypj)
2076             e2=fac*bb!(itypi,itypj)
2077             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2078             eps2der=evdwij*eps3rt
2079             eps3der=evdwij*eps2rt
2080 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
2081 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
2082 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
2083             evdwij=evdwij*eps2rt*eps3rt
2084             evdw=evdw+evdwij*sss_ele_cut
2085             if (lprn) then
2086             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2087             epsi=bb**2/aa!(itypi,itypj)
2088             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2089               restyp(itypi,1),i,restyp(itypj,1),j, &
2090               epsi,sigm,chi1,chi2,chip1,chip2, &
2091               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
2092               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
2093               evdwij
2094             endif
2095
2096             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
2097                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
2098 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
2099 !            if (energy_dec) write (iout,*) &
2100 !                             'evdw',i,j,evdwij
2101 !                       print *,"ZALAMKA", evdw
2102
2103 ! Calculate gradient components.
2104             e1=e1*eps1*eps2rt**2*eps3rt**2
2105             fac=-expon*(e1+evdwij)*rij_shift
2106             sigder=fac*sigder
2107             fac=rij*fac
2108 !            print *,'before fac',fac,rij,evdwij
2109             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
2110             *rij
2111 !            print *,'grad part scale',fac,   &
2112 !             evdwij*sss_ele_grad/sss_ele_cut &
2113 !            /sigma(itypi,itypj)*rij
2114 !            fac=0.0d0
2115 ! Calculate the radial part of the gradient
2116             gg(1)=xj*fac
2117             gg(2)=yj*fac
2118             gg(3)=zj*fac
2119 !C Calculate the radial part of the gradient
2120             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
2121        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
2122         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
2123        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2124             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2125             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2126
2127 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
2128 ! Calculate angular part of the gradient.
2129             call sc_grad
2130             ENDIF    ! dyn_ss
2131 !          enddo      ! j
2132 !        enddo        ! iint
2133       enddo          ! i
2134 !       print *,"ZALAMKA", evdw
2135 !      write (iout,*) "Number of loop steps in EGB:",ind
2136 !ccc      energy_dec=.false.
2137       return
2138       end subroutine egb
2139 !-----------------------------------------------------------------------------
2140       subroutine egbv(evdw)
2141 !
2142 ! This subroutine calculates the interaction energy of nonbonded side chains
2143 ! assuming the Gay-Berne-Vorobjev potential of interaction.
2144 !
2145       use comm_srutu
2146       use calc_data
2147 !      implicit real*8 (a-h,o-z)
2148 !      include 'DIMENSIONS'
2149 !      include 'COMMON.GEO'
2150 !      include 'COMMON.VAR'
2151 !      include 'COMMON.LOCAL'
2152 !      include 'COMMON.CHAIN'
2153 !      include 'COMMON.DERIV'
2154 !      include 'COMMON.NAMES'
2155 !      include 'COMMON.INTERACT'
2156 !      include 'COMMON.IOUNITS'
2157 !      include 'COMMON.CALC'
2158       use comm_srutu
2159 !el      integer :: icall
2160 !el      common /srutu/ icall
2161       logical :: lprn
2162 !el local variables
2163       integer :: iint,itypi,itypi1,itypj
2164       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2, &
2165          sigm,sslipi,ssgradlipi, sslipj,ssgradlipj, aa, bb
2166       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
2167
2168 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2169       evdw=0.0D0
2170       lprn=.false.
2171 !     if (icall.eq.0) lprn=.true.
2172 !el      ind=0
2173       do i=iatsc_s,iatsc_e
2174         itypi=iabs(itype(i,1))
2175         if (itypi.eq.ntyp1) cycle
2176         itypi1=iabs(itype(i+1,1))
2177         xi=c(1,nres+i)
2178         yi=c(2,nres+i)
2179         zi=c(3,nres+i)
2180         call to_box(xi,yi,zi)
2181         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
2182         dxi=dc_norm(1,nres+i)
2183         dyi=dc_norm(2,nres+i)
2184         dzi=dc_norm(3,nres+i)
2185 !        dsci_inv=dsc_inv(itypi)
2186         dsci_inv=vbld_inv(i+nres)
2187 !
2188 ! Calculate SC interaction energy.
2189 !
2190         do iint=1,nint_gr(i)
2191           do j=istart(i,iint),iend(i,iint)
2192 !el            ind=ind+1
2193             itypj=iabs(itype(j,1))
2194             if (itypj.eq.ntyp1) cycle
2195 !            dscj_inv=dsc_inv(itypj)
2196             dscj_inv=vbld_inv(j+nres)
2197             sig0ij=sigma(itypi,itypj)
2198             r0ij=r0(itypi,itypj)
2199             chi1=chi(itypi,itypj)
2200             chi2=chi(itypj,itypi)
2201             chi12=chi1*chi2
2202             chip1=chip(itypi)
2203             chip2=chip(itypj)
2204             chip12=chip1*chip2
2205             alf1=alp(itypi)
2206             alf2=alp(itypj)
2207             alf12=0.5D0*(alf1+alf2)
2208 ! For diagnostics only!!!
2209 !           chi1=0.0D0
2210 !           chi2=0.0D0
2211 !           chi12=0.0D0
2212 !           chip1=0.0D0
2213 !           chip2=0.0D0
2214 !           chip12=0.0D0
2215 !           alf1=0.0D0
2216 !           alf2=0.0D0
2217 !           alf12=0.0D0
2218             xj=c(1,nres+j)-xi
2219             yj=c(2,nres+j)-yi
2220             zj=c(3,nres+j)-zi
2221            call to_box(xj,yj,zj)
2222            call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
2223            aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2224             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2225            bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
2226             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2227            xj=boxshift(xj-xi,boxxsize)
2228            yj=boxshift(yj-yi,boxysize)
2229            zj=boxshift(zj-zi,boxzsize)
2230             dxj=dc_norm(1,nres+j)
2231             dyj=dc_norm(2,nres+j)
2232             dzj=dc_norm(3,nres+j)
2233             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2234             rij=dsqrt(rrij)
2235 ! Calculate angle-dependent terms of energy and contributions to their
2236 ! derivatives.
2237             call sc_angular
2238             sigsq=1.0D0/sigsq
2239             sig=sig0ij*dsqrt(sigsq)
2240             rij_shift=1.0D0/rij-sig+r0ij
2241 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2242             if (rij_shift.le.0.0D0) then
2243               evdw=1.0D20
2244               return
2245             endif
2246             sigder=-sig*sigsq
2247 !---------------------------------------------------------------
2248             rij_shift=1.0D0/rij_shift
2249             fac=rij_shift**expon
2250             e1=fac*fac*aa_aq(itypi,itypj)
2251             e2=fac*bb_aq(itypi,itypj)
2252             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2253             eps2der=evdwij*eps3rt
2254             eps3der=evdwij*eps2rt
2255             fac_augm=rrij**expon
2256             e_augm=augm(itypi,itypj)*fac_augm
2257             evdwij=evdwij*eps2rt*eps3rt
2258             evdw=evdw+evdwij+e_augm
2259             if (lprn) then
2260             sigm=dabs(aa_aq(itypi,itypj)/&
2261             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2262             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2263             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2264               restyp(itypi,1),i,restyp(itypj,1),j,&
2265               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2266               chi1,chi2,chip1,chip2,&
2267               eps1,eps2rt**2,eps3rt**2,&
2268               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2269               evdwij+e_augm
2270             endif
2271 ! Calculate gradient components.
2272             e1=e1*eps1*eps2rt**2*eps3rt**2
2273             fac=-expon*(e1+evdwij)*rij_shift
2274             sigder=fac*sigder
2275             fac=rij*fac-2*expon*rrij*e_augm
2276 ! Calculate the radial part of the gradient
2277             gg(1)=xj*fac
2278             gg(2)=yj*fac
2279             gg(3)=zj*fac
2280 ! Calculate angular part of the gradient.
2281             call sc_grad
2282           enddo      ! j
2283         enddo        ! iint
2284       enddo          ! i
2285       end subroutine egbv
2286 !-----------------------------------------------------------------------------
2287 !el      subroutine sc_angular in module geometry
2288 !-----------------------------------------------------------------------------
2289       subroutine e_softsphere(evdw)
2290 !
2291 ! This subroutine calculates the interaction energy of nonbonded side chains
2292 ! assuming the LJ potential of interaction.
2293 !
2294 !      implicit real*8 (a-h,o-z)
2295 !      include 'DIMENSIONS'
2296       real(kind=8),parameter :: accur=1.0d-10
2297 !      include 'COMMON.GEO'
2298 !      include 'COMMON.VAR'
2299 !      include 'COMMON.LOCAL'
2300 !      include 'COMMON.CHAIN'
2301 !      include 'COMMON.DERIV'
2302 !      include 'COMMON.INTERACT'
2303 !      include 'COMMON.TORSION'
2304 !      include 'COMMON.SBRIDGE'
2305 !      include 'COMMON.NAMES'
2306 !      include 'COMMON.IOUNITS'
2307 !      include 'COMMON.CONTACTS'
2308       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2309 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2310 !el local variables
2311       integer :: i,iint,j,itypi,itypi1,itypj,k
2312       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2313       real(kind=8) :: fac
2314
2315       evdw=0.0D0
2316       do i=iatsc_s,iatsc_e
2317         itypi=iabs(itype(i,1))
2318         if (itypi.eq.ntyp1) cycle
2319         itypi1=iabs(itype(i+1,1))
2320         xi=c(1,nres+i)
2321         yi=c(2,nres+i)
2322         zi=c(3,nres+i)
2323         call to_box(xi,yi,zi)
2324
2325 !
2326 ! Calculate SC interaction energy.
2327 !
2328         do iint=1,nint_gr(i)
2329 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2330 !d   &                  'iend=',iend(i,iint)
2331           do j=istart(i,iint),iend(i,iint)
2332             itypj=iabs(itype(j,1))
2333             if (itypj.eq.ntyp1) cycle
2334             xj=boxshift(c(1,nres+j)-xi,boxxsize)
2335             yj=boxshift(c(2,nres+j)-yi,boxysize)
2336             zj=boxshift(c(3,nres+j)-zi,boxzsize)
2337             rij=xj*xj+yj*yj+zj*zj
2338 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2339             r0ij=r0(itypi,itypj)
2340             r0ijsq=r0ij*r0ij
2341 !            print *,i,j,r0ij,dsqrt(rij)
2342             if (rij.lt.r0ijsq) then
2343               evdwij=0.25d0*(rij-r0ijsq)**2
2344               fac=rij-r0ijsq
2345             else
2346               evdwij=0.0d0
2347               fac=0.0d0
2348             endif
2349             evdw=evdw+evdwij
2350 !
2351 ! Calculate the components of the gradient in DC and X
2352 !
2353             gg(1)=xj*fac
2354             gg(2)=yj*fac
2355             gg(3)=zj*fac
2356             do k=1,3
2357               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2358               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2359               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2360               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2361             enddo
2362 !grad            do k=i,j-1
2363 !grad              do l=1,3
2364 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2365 !grad              enddo
2366 !grad            enddo
2367           enddo ! j
2368         enddo ! iint
2369       enddo ! i
2370       return
2371       end subroutine e_softsphere
2372 !-----------------------------------------------------------------------------
2373       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2374 !
2375 ! Soft-sphere potential of p-p interaction
2376 !
2377 !      implicit real*8 (a-h,o-z)
2378 !      include 'DIMENSIONS'
2379 !      include 'COMMON.CONTROL'
2380 !      include 'COMMON.IOUNITS'
2381 !      include 'COMMON.GEO'
2382 !      include 'COMMON.VAR'
2383 !      include 'COMMON.LOCAL'
2384 !      include 'COMMON.CHAIN'
2385 !      include 'COMMON.DERIV'
2386 !      include 'COMMON.INTERACT'
2387 !      include 'COMMON.CONTACTS'
2388 !      include 'COMMON.TORSION'
2389 !      include 'COMMON.VECTORS'
2390 !      include 'COMMON.FFIELD'
2391       real(kind=8),dimension(3) :: ggg
2392 !d      write(iout,*) 'In EELEC_soft_sphere'
2393 !el local variables
2394       integer :: i,j,k,num_conti,iteli,itelj
2395       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2396       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2397       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2398
2399       ees=0.0D0
2400       evdw1=0.0D0
2401       eel_loc=0.0d0
2402       eello_turn3=0.0d0
2403       eello_turn4=0.0d0
2404 !el      ind=0
2405       do i=iatel_s,iatel_e
2406         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2407         dxi=dc(1,i)
2408         dyi=dc(2,i)
2409         dzi=dc(3,i)
2410         xmedi=c(1,i)+0.5d0*dxi
2411         ymedi=c(2,i)+0.5d0*dyi
2412         zmedi=c(3,i)+0.5d0*dzi
2413         call to_box(xmedi,ymedi,zmedi)
2414         num_conti=0
2415 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2416         do j=ielstart(i),ielend(i)
2417           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2418 !el          ind=ind+1
2419           iteli=itel(i)
2420           itelj=itel(j)
2421           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2422           r0ij=rpp(iteli,itelj)
2423           r0ijsq=r0ij*r0ij
2424           dxj=dc(1,j)
2425           dyj=dc(2,j)
2426           dzj=dc(3,j)
2427           xj=c(1,j)+0.5D0*dxj-xmedi
2428           yj=c(2,j)+0.5D0*dyj-ymedi
2429           zj=c(3,j)+0.5D0*dzj-zmedi
2430           call to_box(xj,yj,zj)
2431           xj=boxshift(xj-xmedi,boxxsize)
2432           yj=boxshift(yj-ymedi,boxysize)
2433           zj=boxshift(zj-zmedi,boxzsize)
2434           rij=xj*xj+yj*yj+zj*zj
2435           if (rij.lt.r0ijsq) then
2436             evdw1ij=0.25d0*(rij-r0ijsq)**2
2437             fac=rij-r0ijsq
2438           else
2439             evdw1ij=0.0d0
2440             fac=0.0d0
2441           endif
2442           evdw1=evdw1+evdw1ij
2443 !
2444 ! Calculate contributions to the Cartesian gradient.
2445 !
2446           ggg(1)=fac*xj
2447           ggg(2)=fac*yj
2448           ggg(3)=fac*zj
2449           do k=1,3
2450             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2451             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2452           enddo
2453 !
2454 ! Loop over residues i+1 thru j-1.
2455 !
2456 !grad          do k=i+1,j-1
2457 !grad            do l=1,3
2458 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2459 !grad            enddo
2460 !grad          enddo
2461         enddo ! j
2462       enddo   ! i
2463 !grad      do i=nnt,nct-1
2464 !grad        do k=1,3
2465 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2466 !grad        enddo
2467 !grad        do j=i+1,nct-1
2468 !grad          do k=1,3
2469 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2470 !grad          enddo
2471 !grad        enddo
2472 !grad      enddo
2473       return
2474       end subroutine eelec_soft_sphere
2475 !-----------------------------------------------------------------------------
2476       subroutine vec_and_deriv
2477 !      implicit real*8 (a-h,o-z)
2478 !      include 'DIMENSIONS'
2479 #ifdef MPI
2480       include 'mpif.h'
2481 #endif
2482 !      include 'COMMON.IOUNITS'
2483 !      include 'COMMON.GEO'
2484 !      include 'COMMON.VAR'
2485 !      include 'COMMON.LOCAL'
2486 !      include 'COMMON.CHAIN'
2487 !      include 'COMMON.VECTORS'
2488 !      include 'COMMON.SETUP'
2489 !      include 'COMMON.TIME1'
2490       real(kind=8),dimension(3,3,2) :: uyder,uzder
2491       real(kind=8),dimension(2) :: vbld_inv_temp
2492 ! Compute the local reference systems. For reference system (i), the
2493 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2494 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2495 !el local variables
2496       integer :: i,j,k,l
2497       real(kind=8) :: facy,fac,costh
2498
2499 #ifdef PARVEC
2500       do i=ivec_start,ivec_end
2501 #else
2502       do i=1,nres-1
2503 #endif
2504           if (i.eq.nres-1) then
2505 ! Case of the last full residue
2506 ! Compute the Z-axis
2507             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2508             costh=dcos(pi-theta(nres))
2509             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2510             do k=1,3
2511               uz(k,i)=fac*uz(k,i)
2512             enddo
2513 ! Compute the derivatives of uz
2514             uzder(1,1,1)= 0.0d0
2515             uzder(2,1,1)=-dc_norm(3,i-1)
2516             uzder(3,1,1)= dc_norm(2,i-1)
2517             uzder(1,2,1)= dc_norm(3,i-1)
2518             uzder(2,2,1)= 0.0d0
2519             uzder(3,2,1)=-dc_norm(1,i-1)
2520             uzder(1,3,1)=-dc_norm(2,i-1)
2521             uzder(2,3,1)= dc_norm(1,i-1)
2522             uzder(3,3,1)= 0.0d0
2523             uzder(1,1,2)= 0.0d0
2524             uzder(2,1,2)= dc_norm(3,i)
2525             uzder(3,1,2)=-dc_norm(2,i)
2526             uzder(1,2,2)=-dc_norm(3,i)
2527             uzder(2,2,2)= 0.0d0
2528             uzder(3,2,2)= dc_norm(1,i)
2529             uzder(1,3,2)= dc_norm(2,i)
2530             uzder(2,3,2)=-dc_norm(1,i)
2531             uzder(3,3,2)= 0.0d0
2532 ! Compute the Y-axis
2533             facy=fac
2534             do k=1,3
2535               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2536             enddo
2537 ! Compute the derivatives of uy
2538             do j=1,3
2539               do k=1,3
2540                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2541                               -dc_norm(k,i)*dc_norm(j,i-1)
2542                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2543               enddo
2544               uyder(j,j,1)=uyder(j,j,1)-costh
2545               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2546             enddo
2547             do j=1,2
2548               do k=1,3
2549                 do l=1,3
2550                   uygrad(l,k,j,i)=uyder(l,k,j)
2551                   uzgrad(l,k,j,i)=uzder(l,k,j)
2552                 enddo
2553               enddo
2554             enddo
2555             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2556             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2557             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2558             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2559           else
2560 ! Other residues
2561 ! Compute the Z-axis
2562             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2563             costh=dcos(pi-theta(i+2))
2564             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2565             do k=1,3
2566               uz(k,i)=fac*uz(k,i)
2567             enddo
2568 ! Compute the derivatives of uz
2569             uzder(1,1,1)= 0.0d0
2570             uzder(2,1,1)=-dc_norm(3,i+1)
2571             uzder(3,1,1)= dc_norm(2,i+1)
2572             uzder(1,2,1)= dc_norm(3,i+1)
2573             uzder(2,2,1)= 0.0d0
2574             uzder(3,2,1)=-dc_norm(1,i+1)
2575             uzder(1,3,1)=-dc_norm(2,i+1)
2576             uzder(2,3,1)= dc_norm(1,i+1)
2577             uzder(3,3,1)= 0.0d0
2578             uzder(1,1,2)= 0.0d0
2579             uzder(2,1,2)= dc_norm(3,i)
2580             uzder(3,1,2)=-dc_norm(2,i)
2581             uzder(1,2,2)=-dc_norm(3,i)
2582             uzder(2,2,2)= 0.0d0
2583             uzder(3,2,2)= dc_norm(1,i)
2584             uzder(1,3,2)= dc_norm(2,i)
2585             uzder(2,3,2)=-dc_norm(1,i)
2586             uzder(3,3,2)= 0.0d0
2587 ! Compute the Y-axis
2588             facy=fac
2589             do k=1,3
2590               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2591             enddo
2592 ! Compute the derivatives of uy
2593             do j=1,3
2594               do k=1,3
2595                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2596                               -dc_norm(k,i)*dc_norm(j,i+1)
2597                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2598               enddo
2599               uyder(j,j,1)=uyder(j,j,1)-costh
2600               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2601             enddo
2602             do j=1,2
2603               do k=1,3
2604                 do l=1,3
2605                   uygrad(l,k,j,i)=uyder(l,k,j)
2606                   uzgrad(l,k,j,i)=uzder(l,k,j)
2607                 enddo
2608               enddo
2609             enddo
2610             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2611             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2612             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2613             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2614           endif
2615       enddo
2616       do i=1,nres-1
2617         vbld_inv_temp(1)=vbld_inv(i+1)
2618         if (i.lt.nres-1) then
2619           vbld_inv_temp(2)=vbld_inv(i+2)
2620           else
2621           vbld_inv_temp(2)=vbld_inv(i)
2622           endif
2623         do j=1,2
2624           do k=1,3
2625             do l=1,3
2626               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2627               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2628             enddo
2629           enddo
2630         enddo
2631       enddo
2632 #if defined(PARVEC) && defined(MPI)
2633       if (nfgtasks1.gt.1) then
2634         time00=MPI_Wtime()
2635 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2636 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2637 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2638         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2639          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2640          FG_COMM1,IERR)
2641         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2642          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2643          FG_COMM1,IERR)
2644         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2645          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2646          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2647         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2648          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2649          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2650         time_gather=time_gather+MPI_Wtime()-time00
2651       endif
2652 !      if (fg_rank.eq.0) then
2653 !        write (iout,*) "Arrays UY and UZ"
2654 !        do i=1,nres-1
2655 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2656 !     &     (uz(k,i),k=1,3)
2657 !        enddo
2658 !      endif
2659 #endif
2660       return
2661       end subroutine vec_and_deriv
2662 !-----------------------------------------------------------------------------
2663       subroutine check_vecgrad
2664 !      implicit real*8 (a-h,o-z)
2665 !      include 'DIMENSIONS'
2666 !      include 'COMMON.IOUNITS'
2667 !      include 'COMMON.GEO'
2668 !      include 'COMMON.VAR'
2669 !      include 'COMMON.LOCAL'
2670 !      include 'COMMON.CHAIN'
2671 !      include 'COMMON.VECTORS'
2672       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2673       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2674       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2675       real(kind=8),dimension(3) :: erij
2676       real(kind=8) :: delta=1.0d-7
2677 !el local variables
2678       integer :: i,j,k,l
2679
2680       call vec_and_deriv
2681 !d      do i=1,nres
2682 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2683 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2684 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2685 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2686 !d     &     (dc_norm(if90,i),if90=1,3)
2687 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2688 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2689 !d          write(iout,'(a)')
2690 !d      enddo
2691       do i=1,nres
2692         do j=1,2
2693           do k=1,3
2694             do l=1,3
2695               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2696               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2697             enddo
2698           enddo
2699         enddo
2700       enddo
2701       call vec_and_deriv
2702       do i=1,nres
2703         do j=1,3
2704           uyt(j,i)=uy(j,i)
2705           uzt(j,i)=uz(j,i)
2706         enddo
2707       enddo
2708       do i=1,nres
2709 !d        write (iout,*) 'i=',i
2710         do k=1,3
2711           erij(k)=dc_norm(k,i)
2712         enddo
2713         do j=1,3
2714           do k=1,3
2715             dc_norm(k,i)=erij(k)
2716           enddo
2717           dc_norm(j,i)=dc_norm(j,i)+delta
2718 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2719 !          do k=1,3
2720 !            dc_norm(k,i)=dc_norm(k,i)/fac
2721 !          enddo
2722 !          write (iout,*) (dc_norm(k,i),k=1,3)
2723 !          write (iout,*) (erij(k),k=1,3)
2724           call vec_and_deriv
2725           do k=1,3
2726             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2727             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2728             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2729             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2730           enddo
2731 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2732 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2733 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2734         enddo
2735         do k=1,3
2736           dc_norm(k,i)=erij(k)
2737         enddo
2738 !d        do k=1,3
2739 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2740 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2741 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2742 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2743 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2744 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2745 !d          write (iout,'(a)')
2746 !d        enddo
2747       enddo
2748       return
2749       end subroutine check_vecgrad
2750 !-----------------------------------------------------------------------------
2751       subroutine set_matrices
2752 !      implicit real*8 (a-h,o-z)
2753 !      include 'DIMENSIONS'
2754 #ifdef MPI
2755       include "mpif.h"
2756 !      include "COMMON.SETUP"
2757       integer :: IERR
2758       integer :: status(MPI_STATUS_SIZE)
2759 #endif
2760 !      include 'COMMON.IOUNITS'
2761 !      include 'COMMON.GEO'
2762 !      include 'COMMON.VAR'
2763 !      include 'COMMON.LOCAL'
2764 !      include 'COMMON.CHAIN'
2765 !      include 'COMMON.DERIV'
2766 !      include 'COMMON.INTERACT'
2767 !      include 'COMMON.CONTACTS'
2768 !      include 'COMMON.TORSION'
2769 !      include 'COMMON.VECTORS'
2770 !      include 'COMMON.FFIELD'
2771       real(kind=8) :: auxvec(2),auxmat(2,2)
2772       integer :: i,iti1,iti,k,l
2773       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2,cost1,sint1,&
2774        sint1sq,sint1cub,sint1cost1,b1k,b2k,aux
2775 !       print *,"in set matrices"
2776 !
2777 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2778 ! to calculate the el-loc multibody terms of various order.
2779 !
2780 !AL el      mu=0.0d0
2781
2782 #ifdef PARMAT
2783       do i=ivec_start+2,ivec_end+2
2784 #else
2785       do i=3,nres+1
2786 #endif
2787         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2788           if (itype(i-2,1).eq.0) then
2789           iti = nloctyp
2790           else
2791           iti = itype2loc(itype(i-2,1))
2792           endif
2793         else
2794           iti=nloctyp
2795         endif
2796 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2797         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2798           iti1 = itype2loc(itype(i-1,1))
2799         else
2800           iti1=nloctyp
2801         endif
2802 !        print *,i,itype(i-2,1),iti
2803 #ifdef NEWCORR
2804         cost1=dcos(theta(i-1))
2805         sint1=dsin(theta(i-1))
2806         sint1sq=sint1*sint1
2807         sint1cub=sint1sq*sint1
2808         sint1cost1=2*sint1*cost1
2809 !        print *,"cost1",cost1,theta(i-1)
2810 !c        write (iout,*) "bnew1",i,iti
2811 !c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2812 !c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2813 !c        write (iout,*) "bnew2",i,iti
2814 !c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2815 !c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2816         k=1
2817 !        print *,bnew1(1,k,iti),"bnew1"
2818         do k=1,2
2819           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2820 !          print *,b1k
2821 !          write(*,*) shape(b1)
2822 !          if(.not.allocated(b1)) print *, "WTF?"
2823           b1(k,i-2)=sint1*b1k
2824 !
2825 !             print *,b1(k,i-2)
2826
2827           gtb1(k,i-2)=cost1*b1k-sint1sq*&
2828                    (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2829 !             print *,gtb1(k,i-2)
2830
2831           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2832           b2(k,i-2)=sint1*b2k
2833 !             print *,b2(k,i-2)
2834
2835           gtb2(k,i-2)=cost1*b2k-sint1sq*&
2836                    (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2837 !             print *,gtb2(k,i-2)
2838
2839         enddo
2840 !        print *,b1k,b2k
2841         do k=1,2
2842           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2843           cc(1,k,i-2)=sint1sq*aux
2844           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*&
2845                    (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2846           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2847           dd(1,k,i-2)=sint1sq*aux
2848           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*&
2849                    (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2850         enddo
2851 !        print *,"after cc"
2852         cc(2,1,i-2)=cc(1,2,i-2)
2853         cc(2,2,i-2)=-cc(1,1,i-2)
2854         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2855         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2856         dd(2,1,i-2)=dd(1,2,i-2)
2857         dd(2,2,i-2)=-dd(1,1,i-2)
2858         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2859         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2860 !        print *,"after dd"
2861
2862         do k=1,2
2863           do l=1,2
2864             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2865             EE(l,k,i-2)=sint1sq*aux
2866             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2867           enddo
2868         enddo
2869         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2870         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2871         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2872         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2873         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2874         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2875         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2876 !        print *,"after ee"
2877
2878 !c        b1tilde(1,i-2)=b1(1,i-2)
2879 !c        b1tilde(2,i-2)=-b1(2,i-2)
2880 !c        b2tilde(1,i-2)=b2(1,i-2)
2881 !c        b2tilde(2,i-2)=-b2(2,i-2)
2882 #ifdef DEBUG
2883         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2884         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2885         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2886         write (iout,*) 'theta=', theta(i-1)
2887 #endif
2888 #else
2889         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2890 !         write(iout,*) "i,",molnum(i),nloctyp
2891 !         print *, "i,",molnum(i),i,itype(i-2,1)
2892         if (molnum(i).eq.1) then
2893           if (itype(i-2,1).eq.ntyp1) then
2894            iti=nloctyp
2895           else
2896           iti = itype2loc(itype(i-2,1))
2897           endif
2898         else
2899           iti=nloctyp
2900         endif
2901         else
2902           iti=nloctyp
2903         endif
2904 !c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2905 !c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2906         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2907           iti1 = itype2loc(itype(i-1,1))
2908         else
2909           iti1=nloctyp
2910         endif
2911 !        print *,i,iti
2912         b1(1,i-2)=b(3,iti)
2913         b1(2,i-2)=b(5,iti)
2914         b2(1,i-2)=b(2,iti)
2915         b2(2,i-2)=b(4,iti)
2916         do k=1,2
2917           do l=1,2
2918            CC(k,l,i-2)=ccold(k,l,iti)
2919            DD(k,l,i-2)=ddold(k,l,iti)
2920            EE(k,l,i-2)=eeold(k,l,iti)
2921           enddo
2922         enddo
2923 #endif
2924         b1tilde(1,i-2)= b1(1,i-2)
2925         b1tilde(2,i-2)=-b1(2,i-2)
2926         b2tilde(1,i-2)= b2(1,i-2)
2927         b2tilde(2,i-2)=-b2(2,i-2)
2928 !c
2929         Ctilde(1,1,i-2)= CC(1,1,i-2)
2930         Ctilde(1,2,i-2)= CC(1,2,i-2)
2931         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2932         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2933 !c
2934         Dtilde(1,1,i-2)= DD(1,1,i-2)
2935         Dtilde(1,2,i-2)= DD(1,2,i-2)
2936         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2937         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2938       enddo
2939 #ifdef PARMAT
2940       do i=ivec_start+2,ivec_end+2
2941 #else
2942       do i=3,nres+1
2943 #endif
2944
2945 !      print *,i,"i"
2946         if (i .lt. nres+1) then
2947           sin1=dsin(phi(i))
2948           cos1=dcos(phi(i))
2949           sintab(i-2)=sin1
2950           costab(i-2)=cos1
2951           obrot(1,i-2)=cos1
2952           obrot(2,i-2)=sin1
2953           sin2=dsin(2*phi(i))
2954           cos2=dcos(2*phi(i))
2955           sintab2(i-2)=sin2
2956           costab2(i-2)=cos2
2957           obrot2(1,i-2)=cos2
2958           obrot2(2,i-2)=sin2
2959           Ug(1,1,i-2)=-cos1
2960           Ug(1,2,i-2)=-sin1
2961           Ug(2,1,i-2)=-sin1
2962           Ug(2,2,i-2)= cos1
2963           Ug2(1,1,i-2)=-cos2
2964           Ug2(1,2,i-2)=-sin2
2965           Ug2(2,1,i-2)=-sin2
2966           Ug2(2,2,i-2)= cos2
2967         else
2968           costab(i-2)=1.0d0
2969           sintab(i-2)=0.0d0
2970           obrot(1,i-2)=1.0d0
2971           obrot(2,i-2)=0.0d0
2972           obrot2(1,i-2)=0.0d0
2973           obrot2(2,i-2)=0.0d0
2974           Ug(1,1,i-2)=1.0d0
2975           Ug(1,2,i-2)=0.0d0
2976           Ug(2,1,i-2)=0.0d0
2977           Ug(2,2,i-2)=1.0d0
2978           Ug2(1,1,i-2)=0.0d0
2979           Ug2(1,2,i-2)=0.0d0
2980           Ug2(2,1,i-2)=0.0d0
2981           Ug2(2,2,i-2)=0.0d0
2982         endif
2983         if (i .gt. 3 .and. i .lt. nres+1) then
2984           obrot_der(1,i-2)=-sin1
2985           obrot_der(2,i-2)= cos1
2986           Ugder(1,1,i-2)= sin1
2987           Ugder(1,2,i-2)=-cos1
2988           Ugder(2,1,i-2)=-cos1
2989           Ugder(2,2,i-2)=-sin1
2990           dwacos2=cos2+cos2
2991           dwasin2=sin2+sin2
2992           obrot2_der(1,i-2)=-dwasin2
2993           obrot2_der(2,i-2)= dwacos2
2994           Ug2der(1,1,i-2)= dwasin2
2995           Ug2der(1,2,i-2)=-dwacos2
2996           Ug2der(2,1,i-2)=-dwacos2
2997           Ug2der(2,2,i-2)=-dwasin2
2998         else
2999           obrot_der(1,i-2)=0.0d0
3000           obrot_der(2,i-2)=0.0d0
3001           Ugder(1,1,i-2)=0.0d0
3002           Ugder(1,2,i-2)=0.0d0
3003           Ugder(2,1,i-2)=0.0d0
3004           Ugder(2,2,i-2)=0.0d0
3005           obrot2_der(1,i-2)=0.0d0
3006           obrot2_der(2,i-2)=0.0d0
3007           Ug2der(1,1,i-2)=0.0d0
3008           Ug2der(1,2,i-2)=0.0d0
3009           Ug2der(2,1,i-2)=0.0d0
3010           Ug2der(2,2,i-2)=0.0d0
3011         endif
3012 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3013         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3014            if (itype(i-2,1).eq.0) then
3015           iti=ntortyp+1
3016            else
3017           iti = itype2loc(itype(i-2,1))
3018            endif
3019         else
3020           iti=nloctyp
3021         endif
3022 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3023         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3024            if (itype(i-1,1).eq.0) then
3025           iti1=nloctyp
3026            else
3027           iti1 = itype2loc(itype(i-1,1))
3028            endif
3029         else
3030           iti1=nloctyp
3031         endif
3032 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
3033 !d        write (iout,*) '*******i',i,' iti1',iti
3034 !        write (iout,*) 'b1',b1(:,iti)
3035 !        write (iout,*) 'b2',b2(:,i-2)
3036 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
3037 !        if (i .gt. iatel_s+2) then
3038         if (i .gt. nnt+2) then
3039           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3040 #ifdef NEWCORR
3041           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3042 !c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3043 #endif
3044
3045           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3046           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3047           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3048           then
3049           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3050           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3051           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3052           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3053           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3054           endif
3055         else
3056           do k=1,2
3057             Ub2(k,i-2)=0.0d0
3058             Ctobr(k,i-2)=0.0d0
3059             Dtobr2(k,i-2)=0.0d0
3060             do l=1,2
3061               EUg(l,k,i-2)=0.0d0
3062               CUg(l,k,i-2)=0.0d0
3063               DUg(l,k,i-2)=0.0d0
3064               DtUg2(l,k,i-2)=0.0d0
3065             enddo
3066           enddo
3067         endif
3068         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3069         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3070         do k=1,2
3071           muder(k,i-2)=Ub2der(k,i-2)
3072         enddo
3073 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3074         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3075           if (itype(i-1,1).eq.0) then
3076            iti1=nloctyp
3077           elseif (itype(i-1,1).le.ntyp) then
3078             iti1 = itype2loc(itype(i-1,1))
3079           else
3080             iti1=nloctyp
3081           endif
3082         else
3083           iti1=nloctyp
3084         endif
3085         do k=1,2
3086           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3087         enddo
3088         if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
3089         if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,i-1)
3090         if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
3091 !d        write (iout,*) 'mu1',mu1(:,i-2)
3092 !d        write (iout,*) 'mu2',mu2(:,i-2)
3093         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3094         then
3095         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3096         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3097         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3098         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3099         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3100 ! Vectors and matrices dependent on a single virtual-bond dihedral.
3101         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3102         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3103         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3104         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3105         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3106         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
3107         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
3108         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
3109         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
3110         endif
3111       enddo
3112 ! Matrices dependent on two consecutive virtual-bond dihedrals.
3113 ! The order of matrices is from left to right.
3114       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
3115       then
3116 !      do i=max0(ivec_start,2),ivec_end
3117       do i=2,nres-1
3118         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3119         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3120         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3121         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3122         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3123         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3124         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3125         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3126       enddo
3127       endif
3128 #if defined(MPI) && defined(PARMAT)
3129 #ifdef DEBUG
3130 !      if (fg_rank.eq.0) then
3131         write (iout,*) "Arrays UG and UGDER before GATHER"
3132         do i=1,nres-1
3133           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3134            ((ug(l,k,i),l=1,2),k=1,2),&
3135            ((ugder(l,k,i),l=1,2),k=1,2)
3136         enddo
3137         write (iout,*) "Arrays UG2 and UG2DER"
3138         do i=1,nres-1
3139           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3140            ((ug2(l,k,i),l=1,2),k=1,2),&
3141            ((ug2der(l,k,i),l=1,2),k=1,2)
3142         enddo
3143         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3144         do i=1,nres-1
3145           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3146            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3147            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3148         enddo
3149         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3150         do i=1,nres-1
3151           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3152            costab(i),sintab(i),costab2(i),sintab2(i)
3153         enddo
3154         write (iout,*) "Array MUDER"
3155         do i=1,nres-1
3156           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3157         enddo
3158 !      endif
3159 #endif
3160       if (nfgtasks.gt.1) then
3161         time00=MPI_Wtime()
3162 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3163 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3164 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3165 #ifdef MATGATHER
3166         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
3167          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3168          FG_COMM1,IERR)
3169         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
3170          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3171          FG_COMM1,IERR)
3172         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
3173          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3174          FG_COMM1,IERR)
3175         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
3176          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3177          FG_COMM1,IERR)
3178         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
3179          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3180          FG_COMM1,IERR)
3181         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
3182          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3183          FG_COMM1,IERR)
3184         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
3185          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
3186          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3187         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
3188          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
3189          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3190         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
3191          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
3192          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3193         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
3194          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
3195          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3196         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3197         then
3198         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
3199          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3200          FG_COMM1,IERR)
3201         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
3202          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3203          FG_COMM1,IERR)
3204         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
3205          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3206          FG_COMM1,IERR)
3207        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
3208          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3209          FG_COMM1,IERR)
3210         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
3211          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3212          FG_COMM1,IERR)
3213         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
3214          ivec_count(fg_rank1),&
3215          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3216          FG_COMM1,IERR)
3217         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
3218          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3219          FG_COMM1,IERR)
3220         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
3221          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
3222          FG_COMM1,IERR)
3223         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
3224          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3225          FG_COMM1,IERR)
3226         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
3227          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3228          FG_COMM1,IERR)
3229         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
3230          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3231          FG_COMM1,IERR)
3232         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
3233          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3234          FG_COMM1,IERR)
3235         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
3236          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3237          FG_COMM1,IERR)
3238         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
3239          ivec_count(fg_rank1),&
3240          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3241          FG_COMM1,IERR)
3242         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
3243          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3244          FG_COMM1,IERR)
3245        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
3246          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3247          FG_COMM1,IERR)
3248         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
3249          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3250          FG_COMM1,IERR)
3251        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
3252          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3253          FG_COMM1,IERR)
3254         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
3255          ivec_count(fg_rank1),&
3256          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3257          FG_COMM1,IERR)
3258         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
3259          ivec_count(fg_rank1),&
3260          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3261          FG_COMM1,IERR)
3262         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
3263          ivec_count(fg_rank1),&
3264          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3265          MPI_MAT2,FG_COMM1,IERR)
3266         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
3267          ivec_count(fg_rank1),&
3268          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3269          MPI_MAT2,FG_COMM1,IERR)
3270         endif
3271 #else
3272 ! Passes matrix info through the ring
3273       isend=fg_rank1
3274       irecv=fg_rank1-1
3275       if (irecv.lt.0) irecv=nfgtasks1-1
3276       iprev=irecv
3277       inext=fg_rank1+1
3278       if (inext.ge.nfgtasks1) inext=0
3279       do i=1,nfgtasks1-1
3280 !        write (iout,*) "isend",isend," irecv",irecv
3281 !        call flush(iout)
3282         lensend=lentyp(isend)
3283         lenrecv=lentyp(irecv)
3284 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3285 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3286 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
3287 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3288 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
3289 !        write (iout,*) "Gather ROTAT1"
3290 !        call flush(iout)
3291 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3292 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
3293 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3294 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
3295 !        write (iout,*) "Gather ROTAT2"
3296 !        call flush(iout)
3297         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
3298          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
3299          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
3300          iprev,4400+irecv,FG_COMM,status,IERR)
3301 !        write (iout,*) "Gather ROTAT_OLD"
3302 !        call flush(iout)
3303         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
3304          MPI_PRECOMP11(lensend),inext,5500+isend,&
3305          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
3306          iprev,5500+irecv,FG_COMM,status,IERR)
3307 !        write (iout,*) "Gather PRECOMP11"
3308 !        call flush(iout)
3309         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
3310          MPI_PRECOMP12(lensend),inext,6600+isend,&
3311          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
3312          iprev,6600+irecv,FG_COMM,status,IERR)
3313 !        write (iout,*) "Gather PRECOMP12"
3314 !        call flush(iout)
3315         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3316         then
3317         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
3318          MPI_ROTAT2(lensend),inext,7700+isend,&
3319          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
3320          iprev,7700+irecv,FG_COMM,status,IERR)
3321 !        write (iout,*) "Gather PRECOMP21"
3322 !        call flush(iout)
3323         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
3324          MPI_PRECOMP22(lensend),inext,8800+isend,&
3325          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
3326          iprev,8800+irecv,FG_COMM,status,IERR)
3327 !        write (iout,*) "Gather PRECOMP22"
3328 !        call flush(iout)
3329         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
3330          MPI_PRECOMP23(lensend),inext,9900+isend,&
3331          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
3332          MPI_PRECOMP23(lenrecv),&
3333          iprev,9900+irecv,FG_COMM,status,IERR)
3334 !        write (iout,*) "Gather PRECOMP23"
3335 !        call flush(iout)
3336         endif
3337         isend=irecv
3338         irecv=irecv-1
3339         if (irecv.lt.0) irecv=nfgtasks1-1
3340       enddo
3341 #endif
3342         time_gather=time_gather+MPI_Wtime()-time00
3343       endif
3344 #ifdef DEBUG
3345 !      if (fg_rank.eq.0) then
3346         write (iout,*) "Arrays UG and UGDER"
3347         do i=1,nres-1
3348           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3349            ((ug(l,k,i),l=1,2),k=1,2),&
3350            ((ugder(l,k,i),l=1,2),k=1,2)
3351         enddo
3352         write (iout,*) "Arrays UG2 and UG2DER"
3353         do i=1,nres-1
3354           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3355            ((ug2(l,k,i),l=1,2),k=1,2),&
3356            ((ug2der(l,k,i),l=1,2),k=1,2)
3357         enddo
3358         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3359         do i=1,nres-1
3360           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3361            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3362            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3363         enddo
3364         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3365         do i=1,nres-1
3366           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3367            costab(i),sintab(i),costab2(i),sintab2(i)
3368         enddo
3369         write (iout,*) "Array MUDER"
3370         do i=1,nres-1
3371           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3372         enddo
3373 !      endif
3374 #endif
3375 #endif
3376 !d      do i=1,nres
3377 !d        iti = itortyp(itype(i,1))
3378 !d        write (iout,*) i
3379 !d        do j=1,2
3380 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3381 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3382 !d        enddo
3383 !d      enddo
3384       return
3385       end subroutine set_matrices
3386 !-----------------------------------------------------------------------------
3387       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3388 !
3389 ! This subroutine calculates the average interaction energy and its gradient
3390 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
3391 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3392 ! The potential depends both on the distance of peptide-group centers and on
3393 ! the orientation of the CA-CA virtual bonds.
3394 !
3395       use comm_locel
3396 !      implicit real*8 (a-h,o-z)
3397 #ifdef MPI
3398       include 'mpif.h'
3399 #endif
3400 !      include 'DIMENSIONS'
3401 !      include 'COMMON.CONTROL'
3402 !      include 'COMMON.SETUP'
3403 !      include 'COMMON.IOUNITS'
3404 !      include 'COMMON.GEO'
3405 !      include 'COMMON.VAR'
3406 !      include 'COMMON.LOCAL'
3407 !      include 'COMMON.CHAIN'
3408 !      include 'COMMON.DERIV'
3409 !      include 'COMMON.INTERACT'
3410 !      include 'COMMON.CONTACTS'
3411 !      include 'COMMON.TORSION'
3412 !      include 'COMMON.VECTORS'
3413 !      include 'COMMON.FFIELD'
3414 !      include 'COMMON.TIME1'
3415       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
3416       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3417       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3418 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3419       real(kind=8),dimension(4) :: muij
3420 !el      integer :: num_conti,j1,j2
3421 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3422 !el        dz_normi,xmedi,ymedi,zmedi
3423
3424 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3425 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3426 !el          num_conti,j1,j2
3427
3428 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3429 #ifdef MOMENT
3430       real(kind=8) :: scal_el=1.0d0
3431 #else
3432       real(kind=8) :: scal_el=0.5d0
3433 #endif
3434 ! 12/13/98
3435 ! 13-go grudnia roku pamietnego...
3436       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3437                                              0.0d0,1.0d0,0.0d0,&
3438                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3439 !el local variables
3440       integer :: i,k,j,icont
3441       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3442       real(kind=8) :: fac,t_eelecij,fracinbuf
3443
3444
3445 !d      write(iout,*) 'In EELEC'
3446 !        print *,"IN EELEC"
3447 !d      do i=1,nloctyp
3448 !d        write(iout,*) 'Type',i
3449 !d        write(iout,*) 'B1',B1(:,i)
3450 !d        write(iout,*) 'B2',B2(:,i)
3451 !d        write(iout,*) 'CC',CC(:,:,i)
3452 !d        write(iout,*) 'DD',DD(:,:,i)
3453 !d        write(iout,*) 'EE',EE(:,:,i)
3454 !d      enddo
3455 !d      call check_vecgrad
3456 !d      stop
3457 !      ees=0.0d0  !AS
3458 !      evdw1=0.0d0
3459 !      eel_loc=0.0d0
3460 !      eello_turn3=0.0d0
3461 !      eello_turn4=0.0d0
3462       t_eelecij=0.0d0
3463       ees=0.0D0
3464       evdw1=0.0D0
3465       eel_loc=0.0d0
3466       eello_turn3=0.0d0
3467       eello_turn4=0.0d0
3468       if (nres_molec(1).eq.0) return
3469 !
3470
3471       if (icheckgrad.eq.1) then
3472 !el
3473 !        do i=0,2*nres+2
3474 !          dc_norm(1,i)=0.0d0
3475 !          dc_norm(2,i)=0.0d0
3476 !          dc_norm(3,i)=0.0d0
3477 !        enddo
3478         do i=1,nres-1
3479           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3480           do k=1,3
3481             dc_norm(k,i)=dc(k,i)*fac
3482           enddo
3483 !          write (iout,*) 'i',i,' fac',fac
3484         enddo
3485       endif
3486 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3487 !        wturn6
3488       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3489           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3490           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3491 !        call vec_and_deriv
3492 #ifdef TIMING
3493         time01=MPI_Wtime()
3494 #endif
3495 !        print *, "before set matrices"
3496         call set_matrices
3497 !        print *, "after set matrices"
3498
3499 #ifdef TIMING
3500         time_mat=time_mat+MPI_Wtime()-time01
3501 #endif
3502       endif
3503 !       print *, "after set matrices"
3504 !d      do i=1,nres-1
3505 !d        write (iout,*) 'i=',i
3506 !d        do k=1,3
3507 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3508 !d        enddo
3509 !d        do k=1,3
3510 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3511 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3512 !d        enddo
3513 !d      enddo
3514       t_eelecij=0.0d0
3515       ees=0.0D0
3516       evdw1=0.0D0
3517       eel_loc=0.0d0
3518       eello_turn3=0.0d0
3519       eello_turn4=0.0d0
3520 !el      ind=0
3521       do i=1,nres
3522         num_cont_hb(i)=0
3523       enddo
3524 !d      print '(a)','Enter EELEC'
3525 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3526 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3527 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3528       do i=1,nres
3529         gel_loc_loc(i)=0.0d0
3530         gcorr_loc(i)=0.0d0
3531       enddo
3532 !
3533 !
3534 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3535 !
3536 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3537 !
3538
3539
3540 !        print *,"before iturn3 loop"
3541       do i=iturn3_start,iturn3_end
3542         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3543         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3544         dxi=dc(1,i)
3545         dyi=dc(2,i)
3546         dzi=dc(3,i)
3547         dx_normi=dc_norm(1,i)
3548         dy_normi=dc_norm(2,i)
3549         dz_normi=dc_norm(3,i)
3550         xmedi=c(1,i)+0.5d0*dxi
3551         ymedi=c(2,i)+0.5d0*dyi
3552         zmedi=c(3,i)+0.5d0*dzi
3553         call to_box(xmedi,ymedi,zmedi)
3554         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3555         num_conti=0
3556        call eelecij(i,i+2,ees,evdw1,eel_loc)
3557         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3558         num_cont_hb(i)=num_conti
3559       enddo
3560       do i=iturn4_start,iturn4_end
3561         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3562           .or. itype(i+3,1).eq.ntyp1 &
3563           .or. itype(i+4,1).eq.ntyp1) cycle
3564 !        print *,"before2",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3565         dxi=dc(1,i)
3566         dyi=dc(2,i)
3567         dzi=dc(3,i)
3568         dx_normi=dc_norm(1,i)
3569         dy_normi=dc_norm(2,i)
3570         dz_normi=dc_norm(3,i)
3571         xmedi=c(1,i)+0.5d0*dxi
3572         ymedi=c(2,i)+0.5d0*dyi
3573         zmedi=c(3,i)+0.5d0*dzi
3574         call to_box(xmedi,ymedi,zmedi)
3575         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3576         num_conti=num_cont_hb(i)
3577         call eelecij(i,i+3,ees,evdw1,eel_loc)
3578         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3579         call eturn4(i,eello_turn4)
3580 !        print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3581         num_cont_hb(i)=num_conti
3582       enddo   ! i
3583 !
3584 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3585 !
3586 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3587 !      do i=iatel_s,iatel_e
3588 ! JPRDLC
3589        do icont=g_listpp_start,g_listpp_end
3590         i=newcontlistppi(icont)
3591         j=newcontlistppj(icont)
3592         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3593         dxi=dc(1,i)
3594         dyi=dc(2,i)
3595         dzi=dc(3,i)
3596         dx_normi=dc_norm(1,i)
3597         dy_normi=dc_norm(2,i)
3598         dz_normi=dc_norm(3,i)
3599         xmedi=c(1,i)+0.5d0*dxi
3600         ymedi=c(2,i)+0.5d0*dyi
3601         zmedi=c(3,i)+0.5d0*dzi
3602         call to_box(xmedi,ymedi,zmedi)
3603         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
3604
3605 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3606         num_conti=num_cont_hb(i)
3607 !        do j=ielstart(i),ielend(i)
3608 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3609           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3610           call eelecij(i,j,ees,evdw1,eel_loc)
3611 !        enddo ! j
3612         num_cont_hb(i)=num_conti
3613       enddo   ! i
3614 !      write (iout,*) "Number of loop steps in EELEC:",ind
3615 !d      do i=1,nres
3616 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3617 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3618 !d      enddo
3619 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3620 !cc      eel_loc=eel_loc+eello_turn3
3621 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3622       return
3623       end subroutine eelec
3624 !-----------------------------------------------------------------------------
3625       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3626
3627       use comm_locel
3628 !      implicit real*8 (a-h,o-z)
3629 !      include 'DIMENSIONS'
3630 #ifdef MPI
3631       include "mpif.h"
3632 #endif
3633 !      include 'COMMON.CONTROL'
3634 !      include 'COMMON.IOUNITS'
3635 !      include 'COMMON.GEO'
3636 !      include 'COMMON.VAR'
3637 !      include 'COMMON.LOCAL'
3638 !      include 'COMMON.CHAIN'
3639 !      include 'COMMON.DERIV'
3640 !      include 'COMMON.INTERACT'
3641 !      include 'COMMON.CONTACTS'
3642 !      include 'COMMON.TORSION'
3643 !      include 'COMMON.VECTORS'
3644 !      include 'COMMON.FFIELD'
3645 !      include 'COMMON.TIME1'
3646       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3647       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3648       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3649 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3650       real(kind=8),dimension(4) :: muij
3651       real(kind=8) :: geel_loc_ij,geel_loc_ji
3652       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3653                     dist_temp, dist_init,rlocshield,fracinbuf
3654       integer xshift,yshift,zshift,ilist,iresshield
3655 !el      integer :: num_conti,j1,j2
3656 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3657 !el        dz_normi,xmedi,ymedi,zmedi
3658
3659 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3660 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3661 !el          num_conti,j1,j2
3662
3663 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3664 #ifdef MOMENT
3665       real(kind=8) :: scal_el=1.0d0
3666 #else
3667       real(kind=8) :: scal_el=0.5d0
3668 #endif
3669 ! 12/13/98
3670 ! 13-go grudnia roku pamietnego...
3671       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3672                                              0.0d0,1.0d0,0.0d0,&
3673                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3674 !      integer :: maxconts=nres/4
3675 !el local variables
3676       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3677       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3678       real(kind=8) ::  faclipij2, faclipij
3679       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3680       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3681                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3682                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3683                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3684                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3685                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3686                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3687                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3688 !      maxconts=nres/4
3689 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3690 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3691
3692 !          time00=MPI_Wtime()
3693 !d      write (iout,*) "eelecij",i,j
3694 !          ind=ind+1
3695           iteli=itel(i)
3696           itelj=itel(j)
3697           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3698           aaa=app(iteli,itelj)
3699           bbb=bpp(iteli,itelj)
3700           ael6i=ael6(iteli,itelj)
3701           ael3i=ael3(iteli,itelj)
3702           dxj=dc(1,j)
3703           dyj=dc(2,j)
3704           dzj=dc(3,j)
3705           dx_normj=dc_norm(1,j)
3706           dy_normj=dc_norm(2,j)
3707           dz_normj=dc_norm(3,j)
3708 !          xj=c(1,j)+0.5D0*dxj-xmedi
3709 !          yj=c(2,j)+0.5D0*dyj-ymedi
3710 !          zj=c(3,j)+0.5D0*dzj-zmedi
3711           xj=c(1,j)+0.5D0*dxj
3712           yj=c(2,j)+0.5D0*dyj
3713           zj=c(3,j)+0.5D0*dzj
3714
3715           call to_box(xj,yj,zj)
3716           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
3717           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
3718           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3719           xj=boxshift(xj-xmedi,boxxsize)
3720           yj=boxshift(yj-ymedi,boxysize)
3721           zj=boxshift(zj-zmedi,boxzsize)
3722
3723           rij=xj*xj+yj*yj+zj*zj
3724           rrmij=1.0D0/rij
3725           rij=dsqrt(rij)
3726 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3727             sss_ele_cut=sscale_ele(rij)
3728             sss_ele_grad=sscagrad_ele(rij)
3729 !             sss_ele_cut=1.0d0
3730 !             sss_ele_grad=0.0d0
3731 !            print *,sss_ele_cut,sss_ele_grad,&
3732 !            (rij),r_cut_ele,rlamb_ele
3733             if (sss_ele_cut.le.0.0) go to 128
3734
3735           rmij=1.0D0/rij
3736           r3ij=rrmij*rmij
3737           r6ij=r3ij*r3ij
3738           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3739           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3740           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3741           fac=cosa-3.0D0*cosb*cosg
3742           ev1=aaa*r6ij*r6ij
3743 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3744           if (j.eq.i+2) ev1=scal_el*ev1
3745           ev2=bbb*r6ij
3746           fac3=ael6i*r6ij
3747           fac4=ael3i*r3ij
3748           evdwij=ev1+ev2
3749           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3750           el2=fac4*fac
3751 !          eesij=el1+el2
3752           if (shield_mode.gt.0) then
3753 !C          fac_shield(i)=0.4
3754 !C          fac_shield(j)=0.6
3755           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3756           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3757           eesij=(el1+el2)
3758           ees=ees+eesij*sss_ele_cut
3759 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3760 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3761           else
3762           fac_shield(i)=1.0
3763           fac_shield(j)=1.0
3764           eesij=(el1+el2)
3765           ees=ees+eesij   &
3766             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3767 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3768           endif
3769
3770 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3771           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3772 !          ees=ees+eesij*sss_ele_cut
3773           evdw1=evdw1+evdwij*sss_ele_cut  &
3774            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3775 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3776 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3777 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3778 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3779
3780           if (energy_dec) then
3781 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3782 !                  'evdw1',i,j,evdwij,&
3783 !                  iteli,itelj,aaa,evdw1
3784               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3785               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3786           endif
3787 !
3788 ! Calculate contributions to the Cartesian gradient.
3789 !
3790 #ifdef SPLITELE
3791           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3792               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3793           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3794              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3795           fac1=fac
3796           erij(1)=xj*rmij
3797           erij(2)=yj*rmij
3798           erij(3)=zj*rmij
3799 !
3800 ! Radial derivatives. First process both termini of the fragment (i,j)
3801 !
3802           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3803           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3804           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3805            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3806           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3807             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3808
3809           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3810           (shield_mode.gt.0)) then
3811 !C          print *,i,j
3812           do ilist=1,ishield_list(i)
3813            iresshield=shield_list(ilist,i)
3814            do k=1,3
3815            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3816            *2.0*sss_ele_cut
3817            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3818                    rlocshield &
3819             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3820             *sss_ele_cut
3821             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3822            enddo
3823           enddo
3824           do ilist=1,ishield_list(j)
3825            iresshield=shield_list(ilist,j)
3826            do k=1,3
3827            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3828           *2.0*sss_ele_cut
3829            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3830                    rlocshield &
3831            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3832            *sss_ele_cut
3833            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3834            enddo
3835           enddo
3836           do k=1,3
3837             gshieldc(k,i)=gshieldc(k,i)+ &
3838                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3839            *sss_ele_cut
3840
3841             gshieldc(k,j)=gshieldc(k,j)+ &
3842                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3843            *sss_ele_cut
3844
3845             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3846                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3847            *sss_ele_cut
3848
3849             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3850                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3851            *sss_ele_cut
3852
3853            enddo
3854            endif
3855
3856
3857 !          do k=1,3
3858 !            ghalf=0.5D0*ggg(k)
3859 !            gelc(k,i)=gelc(k,i)+ghalf
3860 !            gelc(k,j)=gelc(k,j)+ghalf
3861 !          enddo
3862 ! 9/28/08 AL Gradient compotents will be summed only at the end
3863           do k=1,3
3864             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3865             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3866           enddo
3867             gelc_long(3,j)=gelc_long(3,j)+  &
3868           ssgradlipj*eesij/2.0d0*lipscale**2&
3869            *sss_ele_cut
3870
3871             gelc_long(3,i)=gelc_long(3,i)+  &
3872           ssgradlipi*eesij/2.0d0*lipscale**2&
3873            *sss_ele_cut
3874
3875
3876 !
3877 ! Loop over residues i+1 thru j-1.
3878 !
3879 !grad          do k=i+1,j-1
3880 !grad            do l=1,3
3881 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3882 !grad            enddo
3883 !grad          enddo
3884           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3885            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3886           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3887            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3888           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3889            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3890
3891 !          do k=1,3
3892 !            ghalf=0.5D0*ggg(k)
3893 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3894 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3895 !          enddo
3896 ! 9/28/08 AL Gradient compotents will be summed only at the end
3897           do k=1,3
3898             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3899             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3900           enddo
3901
3902 !C Lipidic part for scaling weight
3903            gvdwpp(3,j)=gvdwpp(3,j)+ &
3904           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3905            gvdwpp(3,i)=gvdwpp(3,i)+ &
3906           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3907 !! Loop over residues i+1 thru j-1.
3908 !
3909 !grad          do k=i+1,j-1
3910 !grad            do l=1,3
3911 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3912 !grad            enddo
3913 !grad          enddo
3914 #else
3915           facvdw=(ev1+evdwij)*sss_ele_cut &
3916            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3917
3918           facel=(el1+eesij)*sss_ele_cut
3919           fac1=fac
3920           fac=-3*rrmij*(facvdw+facvdw+facel)
3921           erij(1)=xj*rmij
3922           erij(2)=yj*rmij
3923           erij(3)=zj*rmij
3924 !
3925 ! Radial derivatives. First process both termini of the fragment (i,j)
3926 !
3927           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3928           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3929           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3930 !          do k=1,3
3931 !            ghalf=0.5D0*ggg(k)
3932 !            gelc(k,i)=gelc(k,i)+ghalf
3933 !            gelc(k,j)=gelc(k,j)+ghalf
3934 !          enddo
3935 ! 9/28/08 AL Gradient compotents will be summed only at the end
3936           do k=1,3
3937             gelc_long(k,j)=gelc(k,j)+ggg(k)
3938             gelc_long(k,i)=gelc(k,i)-ggg(k)
3939           enddo
3940 !
3941 ! Loop over residues i+1 thru j-1.
3942 !
3943 !grad          do k=i+1,j-1
3944 !grad            do l=1,3
3945 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3946 !grad            enddo
3947 !grad          enddo
3948 ! 9/28/08 AL Gradient compotents will be summed only at the end
3949           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3950            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3951           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3952            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3953           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3954            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3955
3956           do k=1,3
3957             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3958             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3959           enddo
3960            gvdwpp(3,j)=gvdwpp(3,j)+ &
3961           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3962            gvdwpp(3,i)=gvdwpp(3,i)+ &
3963           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3964
3965 #endif
3966 !
3967 ! Angular part
3968 !
3969           ecosa=2.0D0*fac3*fac1+fac4
3970           fac4=-3.0D0*fac4
3971           fac3=-6.0D0*fac3
3972           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3973           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3974           do k=1,3
3975             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3976             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3977           enddo
3978 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3979 !d   &          (dcosg(k),k=1,3)
3980           do k=1,3
3981             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3982              *fac_shield(i)**2*fac_shield(j)**2 &
3983              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3984
3985           enddo
3986 !          do k=1,3
3987 !            ghalf=0.5D0*ggg(k)
3988 !            gelc(k,i)=gelc(k,i)+ghalf
3989 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3990 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3991 !            gelc(k,j)=gelc(k,j)+ghalf
3992 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3993 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3994 !          enddo
3995 !grad          do k=i+1,j-1
3996 !grad            do l=1,3
3997 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3998 !grad            enddo
3999 !grad          enddo
4000           do k=1,3
4001             gelc(k,i)=gelc(k,i) &
4002                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4003                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
4004                      *sss_ele_cut &
4005                      *fac_shield(i)**2*fac_shield(j)**2 &
4006                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4007
4008             gelc(k,j)=gelc(k,j) &
4009                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4010                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4011                      *sss_ele_cut  &
4012                      *fac_shield(i)**2*fac_shield(j)**2  &
4013                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
4014
4015             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4016             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4017           enddo
4018
4019           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
4020               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
4021               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4022 !
4023 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4024 !   energy of a peptide unit is assumed in the form of a second-order
4025 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4026 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4027 !   are computed for EVERY pair of non-contiguous peptide groups.
4028 !
4029           if (j.lt.nres-1) then
4030             j1=j+1
4031             j2=j-1
4032           else
4033             j1=j-1
4034             j2=j-2
4035           endif
4036           kkk=0
4037           do k=1,2
4038             do l=1,2
4039               kkk=kkk+1
4040               muij(kkk)=mu(k,i)*mu(l,j)
4041 #ifdef NEWCORR
4042              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4043 !c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4044              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4045              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4046 !c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4047              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4048 #endif
4049
4050             enddo
4051           enddo
4052 !d         write (iout,*) 'EELEC: i',i,' j',j
4053 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
4054 !d          write(iout,*) 'muij',muij
4055           ury=scalar(uy(1,i),erij)
4056           urz=scalar(uz(1,i),erij)
4057           vry=scalar(uy(1,j),erij)
4058           vrz=scalar(uz(1,j),erij)
4059           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4060           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4061           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4062           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4063           fac=dsqrt(-ael6i)*r3ij
4064           a22=a22*fac
4065           a23=a23*fac
4066           a32=a32*fac
4067           a33=a33*fac
4068 !d          write (iout,'(4i5,4f10.5)')
4069 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
4070 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4071 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4072 !d     &      uy(:,j),uz(:,j)
4073 !d          write (iout,'(4f10.5)')
4074 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4075 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4076 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
4077 !d           write (iout,'(9f10.5/)')
4078 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4079 ! Derivatives of the elements of A in virtual-bond vectors
4080           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4081           do k=1,3
4082             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4083             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4084             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4085             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4086             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4087             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4088             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4089             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4090             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4091             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4092             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4093             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4094           enddo
4095 ! Compute radial contributions to the gradient
4096           facr=-3.0d0*rrmij
4097           a22der=a22*facr
4098           a23der=a23*facr
4099           a32der=a32*facr
4100           a33der=a33*facr
4101           agg(1,1)=a22der*xj
4102           agg(2,1)=a22der*yj
4103           agg(3,1)=a22der*zj
4104           agg(1,2)=a23der*xj
4105           agg(2,2)=a23der*yj
4106           agg(3,2)=a23der*zj
4107           agg(1,3)=a32der*xj
4108           agg(2,3)=a32der*yj
4109           agg(3,3)=a32der*zj
4110           agg(1,4)=a33der*xj
4111           agg(2,4)=a33der*yj
4112           agg(3,4)=a33der*zj
4113 ! Add the contributions coming from er
4114           fac3=-3.0d0*fac
4115           do k=1,3
4116             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4117             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4118             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4119             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4120           enddo
4121           do k=1,3
4122 ! Derivatives in DC(i)
4123 !grad            ghalf1=0.5d0*agg(k,1)
4124 !grad            ghalf2=0.5d0*agg(k,2)
4125 !grad            ghalf3=0.5d0*agg(k,3)
4126 !grad            ghalf4=0.5d0*agg(k,4)
4127             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
4128             -3.0d0*uryg(k,2)*vry)!+ghalf1
4129             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
4130             -3.0d0*uryg(k,2)*vrz)!+ghalf2
4131             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
4132             -3.0d0*urzg(k,2)*vry)!+ghalf3
4133             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
4134             -3.0d0*urzg(k,2)*vrz)!+ghalf4
4135 ! Derivatives in DC(i+1)
4136             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
4137             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4138             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
4139             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4140             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
4141             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4142             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
4143             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4144 ! Derivatives in DC(j)
4145             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
4146             -3.0d0*vryg(k,2)*ury)!+ghalf1
4147             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
4148             -3.0d0*vrzg(k,2)*ury)!+ghalf2
4149             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
4150             -3.0d0*vryg(k,2)*urz)!+ghalf3
4151             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
4152             -3.0d0*vrzg(k,2)*urz)!+ghalf4
4153 ! Derivatives in DC(j+1) or DC(nres-1)
4154             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
4155             -3.0d0*vryg(k,3)*ury)
4156             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
4157             -3.0d0*vrzg(k,3)*ury)
4158             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
4159             -3.0d0*vryg(k,3)*urz)
4160             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
4161             -3.0d0*vrzg(k,3)*urz)
4162 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
4163 !grad              do l=1,4
4164 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4165 !grad              enddo
4166 !grad            endif
4167           enddo
4168           acipa(1,1)=a22
4169           acipa(1,2)=a23
4170           acipa(2,1)=a32
4171           acipa(2,2)=a33
4172           a22=-a22
4173           a23=-a23
4174           do l=1,2
4175             do k=1,3
4176               agg(k,l)=-agg(k,l)
4177               aggi(k,l)=-aggi(k,l)
4178               aggi1(k,l)=-aggi1(k,l)
4179               aggj(k,l)=-aggj(k,l)
4180               aggj1(k,l)=-aggj1(k,l)
4181             enddo
4182           enddo
4183           if (j.lt.nres-1) then
4184             a22=-a22
4185             a32=-a32
4186             do l=1,3,2
4187               do k=1,3
4188                 agg(k,l)=-agg(k,l)
4189                 aggi(k,l)=-aggi(k,l)
4190                 aggi1(k,l)=-aggi1(k,l)
4191                 aggj(k,l)=-aggj(k,l)
4192                 aggj1(k,l)=-aggj1(k,l)
4193               enddo
4194             enddo
4195           else
4196             a22=-a22
4197             a23=-a23
4198             a32=-a32
4199             a33=-a33
4200             do l=1,4
4201               do k=1,3
4202                 agg(k,l)=-agg(k,l)
4203                 aggi(k,l)=-aggi(k,l)
4204                 aggi1(k,l)=-aggi1(k,l)
4205                 aggj(k,l)=-aggj(k,l)
4206                 aggj1(k,l)=-aggj1(k,l)
4207               enddo
4208             enddo
4209           endif
4210           ENDIF ! WCORR
4211           IF (wel_loc.gt.0.0d0) THEN
4212 ! Contribution to the local-electrostatic energy coming from the i-j pair
4213           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
4214            +a33*muij(4)
4215           if (shield_mode.eq.0) then
4216            fac_shield(i)=1.0
4217            fac_shield(j)=1.0
4218           endif
4219           eel_loc_ij=eel_loc_ij &
4220          *fac_shield(i)*fac_shield(j) &
4221          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4222 !C Now derivative over eel_loc
4223           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
4224          (shield_mode.gt.0)) then
4225 !C          print *,i,j
4226
4227           do ilist=1,ishield_list(i)
4228            iresshield=shield_list(ilist,i)
4229            do k=1,3
4230            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
4231                                                 /fac_shield(i)&
4232            *sss_ele_cut
4233            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4234                    rlocshield  &
4235           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
4236           *sss_ele_cut
4237
4238             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4239            +rlocshield
4240            enddo
4241           enddo
4242           do ilist=1,ishield_list(j)
4243            iresshield=shield_list(ilist,j)
4244            do k=1,3
4245            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
4246                                             /fac_shield(j)   &
4247             *sss_ele_cut
4248            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4249                    rlocshield  &
4250       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
4251        *sss_ele_cut
4252
4253            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4254                   +rlocshield
4255
4256            enddo
4257           enddo
4258
4259           do k=1,3
4260             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
4261                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4262                     *sss_ele_cut
4263             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
4264                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4265                     *sss_ele_cut
4266             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
4267                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4268                     *sss_ele_cut
4269             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
4270                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4271                     *sss_ele_cut
4272
4273            enddo
4274            endif
4275
4276 #ifdef NEWCORR
4277          geel_loc_ij=(a22*gmuij1(1)&
4278           +a23*gmuij1(2)&
4279           +a32*gmuij1(3)&
4280           +a33*gmuij1(4))&
4281          *fac_shield(i)*fac_shield(j)&
4282                     *sss_ele_cut     &
4283          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4284
4285
4286 !c         write(iout,*) "derivative over thatai"
4287 !c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4288 !c     &   a33*gmuij1(4)
4289          gloc(nphi+i,icg)=gloc(nphi+i,icg)+&
4290            geel_loc_ij*wel_loc
4291 !c         write(iout,*) "derivative over thatai-1"
4292 !c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4293 !c     &   a33*gmuij2(4)
4294          geel_loc_ij=&
4295           a22*gmuij2(1)&
4296           +a23*gmuij2(2)&
4297           +a32*gmuij2(3)&
4298           +a33*gmuij2(4)
4299          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+&
4300            geel_loc_ij*wel_loc&
4301          *fac_shield(i)*fac_shield(j)&
4302                     *sss_ele_cut &
4303          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4304
4305
4306 !c  Derivative over j residue
4307          geel_loc_ji=a22*gmuji1(1)&
4308           +a23*gmuji1(2)&
4309           +a32*gmuji1(3)&
4310           +a33*gmuji1(4)
4311 !c         write(iout,*) "derivative over thataj"
4312 !c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4313 !c     &   a33*gmuji1(4)
4314
4315         gloc(nphi+j,icg)=gloc(nphi+j,icg)+&
4316            geel_loc_ji*wel_loc&
4317          *fac_shield(i)*fac_shield(j)&
4318                     *sss_ele_cut &
4319          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4320
4321
4322          geel_loc_ji=&
4323           +a22*gmuji2(1)&
4324           +a23*gmuji2(2)&
4325           +a32*gmuji2(3)&
4326           +a33*gmuji2(4)
4327 !c         write(iout,*) "derivative over thataj-1"
4328 !c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4329 !c     &   a33*gmuji2(4)
4330          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+&
4331            geel_loc_ji*wel_loc&
4332          *fac_shield(i)*fac_shield(j)&
4333                     *sss_ele_cut &
4334          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4335
4336 #endif
4337
4338 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4339 !           eel_loc_ij=0.0
4340 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4341 !                  'eelloc',i,j,eel_loc_ij
4342           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
4343                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4344 !           print *,"EELLOC",i,gel_loc_loc(i-1)
4345
4346 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4347 !          if (energy_dec) write (iout,*) "muij",muij
4348 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
4349
4350           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
4351 ! Partial derivatives in virtual-bond dihedral angles gamma
4352           if (i.gt.1) &
4353           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
4354                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
4355                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
4356                  *sss_ele_cut  &
4357           *fac_shield(i)*fac_shield(j) &
4358           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4359
4360           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
4361                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
4362                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
4363                  *sss_ele_cut &
4364           *fac_shield(i)*fac_shield(j) &
4365           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4366 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4367 !          do l=1,3
4368 !            ggg(1)=(agg(1,1)*muij(1)+ &
4369 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
4370 !            *sss_ele_cut &
4371 !             +eel_loc_ij*sss_ele_grad*rmij*xj
4372 !            ggg(2)=(agg(2,1)*muij(1)+ &
4373 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4374 !            *sss_ele_cut &
4375 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4376 !            ggg(3)=(agg(3,1)*muij(1)+ &
4377 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4378 !            *sss_ele_cut &
4379 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4380            xtemp(1)=xj
4381            xtemp(2)=yj
4382            xtemp(3)=zj
4383
4384            do l=1,3
4385             ggg(l)=(agg(l,1)*muij(1)+ &
4386                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4387             *sss_ele_cut &
4388           *fac_shield(i)*fac_shield(j) &
4389           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4390              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4391
4392
4393             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4394             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4395 !grad            ghalf=0.5d0*ggg(l)
4396 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4397 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4398           enddo
4399             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4400           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4401           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4402
4403             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4404           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4405           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4406
4407 !grad          do k=i+1,j2
4408 !grad            do l=1,3
4409 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4410 !grad            enddo
4411 !grad          enddo
4412 ! Remaining derivatives of eello
4413           do l=1,3
4414             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4415                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4416             *sss_ele_cut &
4417           *fac_shield(i)*fac_shield(j) &
4418           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4419
4420 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4421             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4422                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4423             +aggi1(l,4)*muij(4))&
4424             *sss_ele_cut &
4425           *fac_shield(i)*fac_shield(j) &
4426           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4427
4428 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4429             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4430                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4431             *sss_ele_cut &
4432           *fac_shield(i)*fac_shield(j) &
4433           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4434
4435 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4436             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4437                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4438             +aggj1(l,4)*muij(4))&
4439             *sss_ele_cut &
4440           *fac_shield(i)*fac_shield(j) &
4441          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4442
4443 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4444           enddo
4445           ENDIF
4446 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4447 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4448           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4449              .and. num_conti.le.maxconts) then
4450 !            write (iout,*) i,j," entered corr"
4451 !
4452 ! Calculate the contact function. The ith column of the array JCONT will
4453 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4454 ! greater than I). The arrays FACONT and GACONT will contain the values of
4455 ! the contact function and its derivative.
4456 !           r0ij=1.02D0*rpp(iteli,itelj)
4457 !           r0ij=1.11D0*rpp(iteli,itelj)
4458             r0ij=2.20D0*rpp(iteli,itelj)
4459 !           r0ij=1.55D0*rpp(iteli,itelj)
4460             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4461 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4462             if (fcont.gt.0.0D0) then
4463               num_conti=num_conti+1
4464               if (num_conti.gt.maxconts) then
4465 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4466 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4467                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4468                                ' will skip next contacts for this conf.', num_conti
4469               else
4470                 jcont_hb(num_conti,i)=j
4471 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4472 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4473                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4474                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4475 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4476 !  terms.
4477                 d_cont(num_conti,i)=rij
4478 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4479 !     --- Electrostatic-interaction matrix ---
4480                 a_chuj(1,1,num_conti,i)=a22
4481                 a_chuj(1,2,num_conti,i)=a23
4482                 a_chuj(2,1,num_conti,i)=a32
4483                 a_chuj(2,2,num_conti,i)=a33
4484 !     --- Gradient of rij
4485                 do kkk=1,3
4486                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4487                 enddo
4488                 kkll=0
4489                 do k=1,2
4490                   do l=1,2
4491                     kkll=kkll+1
4492                     do m=1,3
4493                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4494                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4495                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4496                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4497                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4498                     enddo
4499                   enddo
4500                 enddo
4501                 ENDIF
4502                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4503 ! Calculate contact energies
4504                 cosa4=4.0D0*cosa
4505                 wij=cosa-3.0D0*cosb*cosg
4506                 cosbg1=cosb+cosg
4507                 cosbg2=cosb-cosg
4508 !               fac3=dsqrt(-ael6i)/r0ij**3
4509                 fac3=dsqrt(-ael6i)*r3ij
4510 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4511                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4512                 if (ees0tmp.gt.0) then
4513                   ees0pij=dsqrt(ees0tmp)
4514                 else
4515                   ees0pij=0
4516                 endif
4517                 if (shield_mode.eq.0) then
4518                 fac_shield(i)=1.0d0
4519                 fac_shield(j)=1.0d0
4520                 else
4521                 ees0plist(num_conti,i)=j
4522                 endif
4523 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4524                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4525                 if (ees0tmp.gt.0) then
4526                   ees0mij=dsqrt(ees0tmp)
4527                 else
4528                   ees0mij=0
4529                 endif
4530 !               ees0mij=0.0D0
4531                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4532                      *sss_ele_cut &
4533                      *fac_shield(i)*fac_shield(j)
4534 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4535
4536                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4537                      *sss_ele_cut &
4538                      *fac_shield(i)*fac_shield(j)
4539 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4540
4541 ! Diagnostics. Comment out or remove after debugging!
4542 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4543 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4544 !               ees0m(num_conti,i)=0.0D0
4545 ! End diagnostics.
4546 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4547 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4548 ! Angular derivatives of the contact function
4549                 ees0pij1=fac3/ees0pij
4550                 ees0mij1=fac3/ees0mij
4551                 fac3p=-3.0D0*fac3*rrmij
4552                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4553                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4554 !               ees0mij1=0.0D0
4555                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4556                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4557                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4558                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4559                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4560                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4561                 ecosap=ecosa1+ecosa2
4562                 ecosbp=ecosb1+ecosb2
4563                 ecosgp=ecosg1+ecosg2
4564                 ecosam=ecosa1-ecosa2
4565                 ecosbm=ecosb1-ecosb2
4566                 ecosgm=ecosg1-ecosg2
4567 ! Diagnostics
4568 !               ecosap=ecosa1
4569 !               ecosbp=ecosb1
4570 !               ecosgp=ecosg1
4571 !               ecosam=0.0D0
4572 !               ecosbm=0.0D0
4573 !               ecosgm=0.0D0
4574 ! End diagnostics
4575                 facont_hb(num_conti,i)=fcont
4576                 fprimcont=fprimcont/rij
4577 !d              facont_hb(num_conti,i)=1.0D0
4578 ! Following line is for diagnostics.
4579 !d              fprimcont=0.0D0
4580                 do k=1,3
4581                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4582                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4583                 enddo
4584                 do k=1,3
4585                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4586                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4587                 enddo
4588                 gggp(1)=gggp(1)+ees0pijp*xj &
4589                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4590                 gggp(2)=gggp(2)+ees0pijp*yj &
4591                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4592                 gggp(3)=gggp(3)+ees0pijp*zj &
4593                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4594
4595                 gggm(1)=gggm(1)+ees0mijp*xj &
4596                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4597
4598                 gggm(2)=gggm(2)+ees0mijp*yj &
4599                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4600
4601                 gggm(3)=gggm(3)+ees0mijp*zj &
4602                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4603
4604 ! Derivatives due to the contact function
4605                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4606                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4607                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4608                 do k=1,3
4609 !
4610 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4611 !          following the change of gradient-summation algorithm.
4612 !
4613 !grad                  ghalfp=0.5D0*gggp(k)
4614 !grad                  ghalfm=0.5D0*gggm(k)
4615                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4616                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4617                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4618                      *sss_ele_cut*fac_shield(i)*fac_shield(j) ! &
4619 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4620
4621
4622                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4623                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4624                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4625                      *sss_ele_cut*fac_shield(i)*fac_shield(j)!   &
4626 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4627
4628
4629                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4630                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4631 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4632
4633                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4634                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4635                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4636                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4637 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4638
4639                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4640                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4641                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4642                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4643 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4644
4645                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4646                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4647 !                     *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4648
4649                 enddo
4650 ! Diagnostics. Comment out or remove after debugging!
4651 !diag           do k=1,3
4652 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4653 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4654 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4655 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4656 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4657 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4658 !diag           enddo
4659               ENDIF ! wcorr
4660               endif  ! num_conti.le.maxconts
4661             endif  ! fcont.gt.0
4662           endif    ! j.gt.i+1
4663           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4664             do k=1,4
4665               do l=1,3
4666                 ghalf=0.5d0*agg(l,k)
4667                 aggi(l,k)=aggi(l,k)+ghalf
4668                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4669                 aggj(l,k)=aggj(l,k)+ghalf
4670               enddo
4671             enddo
4672             if (j.eq.nres-1 .and. i.lt.j-2) then
4673               do k=1,4
4674                 do l=1,3
4675                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4676                 enddo
4677               enddo
4678             endif
4679           endif
4680  128  continue
4681 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4682       return
4683       end subroutine eelecij
4684 !-----------------------------------------------------------------------------
4685       subroutine eturn3(i,eello_turn3)
4686 ! Third- and fourth-order contributions from turns
4687
4688       use comm_locel
4689 !      implicit real*8 (a-h,o-z)
4690 !      include 'DIMENSIONS'
4691 !      include 'COMMON.IOUNITS'
4692 !      include 'COMMON.GEO'
4693 !      include 'COMMON.VAR'
4694 !      include 'COMMON.LOCAL'
4695 !      include 'COMMON.CHAIN'
4696 !      include 'COMMON.DERIV'
4697 !      include 'COMMON.INTERACT'
4698 !      include 'COMMON.CONTACTS'
4699 !      include 'COMMON.TORSION'
4700 !      include 'COMMON.VECTORS'
4701 !      include 'COMMON.FFIELD'
4702 !      include 'COMMON.CONTROL'
4703       real(kind=8),dimension(3) :: ggg
4704       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4705         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,gpizda1,&
4706        gpizda2,auxgmat1,auxgmatt1,auxgmat2,auxgmatt2
4707
4708       real(kind=8),dimension(2) :: auxvec,auxvec1
4709 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4710       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4711 !el      integer :: num_conti,j1,j2
4712 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4713 !el        dz_normi,xmedi,ymedi,zmedi
4714
4715 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4716 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4717 !el         num_conti,j1,j2
4718 !el local variables
4719       integer :: i,j,l,k,ilist,iresshield
4720       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield,xj,yj
4721       xj=0.0d0
4722       yj=0.0d0
4723       j=i+2
4724 !      write (iout,*) "eturn3",i,j,j1,j2
4725           zj=(c(3,j)+c(3,j+1))/2.0d0
4726             call to_box(xj,yj,zj)
4727             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
4728
4729       a_temp(1,1)=a22
4730       a_temp(1,2)=a23
4731       a_temp(2,1)=a32
4732       a_temp(2,2)=a33
4733 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4734 !
4735 !               Third-order contributions
4736 !
4737 !                 (i+2)o----(i+3)
4738 !                      | |
4739 !                      | |
4740 !                 (i+1)o----i
4741 !
4742 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4743 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4744         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4745         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4746         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4747         call transpose2(auxmat(1,1),auxmat1(1,1))
4748         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4749         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4750         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4751         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4752         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4753
4754         if (shield_mode.eq.0) then
4755         fac_shield(i)=1.0d0
4756         fac_shield(j)=1.0d0
4757         endif
4758
4759         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4760          *fac_shield(i)*fac_shield(j)  &
4761          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4762         eello_t3= &
4763         0.5d0*(pizda(1,1)+pizda(2,2)) &
4764         *fac_shield(i)*fac_shield(j)
4765
4766         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4767                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4768 !C#ifdef NEWCORR
4769 !C Derivatives in theta
4770         gloc(nphi+i,icg)=gloc(nphi+i,icg) &
4771        +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3&
4772         *fac_shield(i)*fac_shield(j) &
4773         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4774
4775         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)&
4776        +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3&
4777         *fac_shield(i)*fac_shield(j) &
4778         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4779
4780
4781 !C#endif
4782
4783
4784
4785           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4786        (shield_mode.gt.0)) then
4787 !C          print *,i,j
4788
4789           do ilist=1,ishield_list(i)
4790            iresshield=shield_list(ilist,i)
4791            do k=1,3
4792            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4793            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4794                    rlocshield &
4795            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4796             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4797              +rlocshield
4798            enddo
4799           enddo
4800           do ilist=1,ishield_list(j)
4801            iresshield=shield_list(ilist,j)
4802            do k=1,3
4803            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4804            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4805                    rlocshield &
4806            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4807            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4808                   +rlocshield
4809
4810            enddo
4811           enddo
4812
4813           do k=1,3
4814             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4815                    grad_shield(k,i)*eello_t3/fac_shield(i)
4816             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4817                    grad_shield(k,j)*eello_t3/fac_shield(j)
4818             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4819                    grad_shield(k,i)*eello_t3/fac_shield(i)
4820             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4821                    grad_shield(k,j)*eello_t3/fac_shield(j)
4822            enddo
4823            endif
4824
4825 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4826 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4827 !d     &    ' eello_turn3_num',4*eello_turn3_num
4828 ! Derivatives in gamma(i)
4829         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4830         call transpose2(auxmat2(1,1),auxmat3(1,1))
4831         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4832         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4833           *fac_shield(i)*fac_shield(j)        &
4834           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4835 ! Derivatives in gamma(i+1)
4836         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4837         call transpose2(auxmat2(1,1),auxmat3(1,1))
4838         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4839         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4840           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4841           *fac_shield(i)*fac_shield(j)        &
4842           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4843
4844 ! Cartesian derivatives
4845         do l=1,3
4846 !            ghalf1=0.5d0*agg(l,1)
4847 !            ghalf2=0.5d0*agg(l,2)
4848 !            ghalf3=0.5d0*agg(l,3)
4849 !            ghalf4=0.5d0*agg(l,4)
4850           a_temp(1,1)=aggi(l,1)!+ghalf1
4851           a_temp(1,2)=aggi(l,2)!+ghalf2
4852           a_temp(2,1)=aggi(l,3)!+ghalf3
4853           a_temp(2,2)=aggi(l,4)!+ghalf4
4854           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4855           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4856             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4857           *fac_shield(i)*fac_shield(j)      &
4858           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4859
4860           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4861           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4862           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4863           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4864           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4865           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
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)=aggj(l,1)!+ghalf1
4871           a_temp(1,2)=aggj(l,2)!+ghalf2
4872           a_temp(2,1)=aggj(l,3)!+ghalf3
4873           a_temp(2,2)=aggj(l,4)!+ghalf4
4874           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4875           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
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)=aggj1(l,1)
4881           a_temp(1,2)=aggj1(l,2)
4882           a_temp(2,1)=aggj1(l,3)
4883           a_temp(2,2)=aggj1(l,4)
4884           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4885           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
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         enddo
4890          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4891           ssgradlipi*eello_t3/4.0d0*lipscale
4892          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4893           ssgradlipj*eello_t3/4.0d0*lipscale
4894          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4895           ssgradlipi*eello_t3/4.0d0*lipscale
4896          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4897           ssgradlipj*eello_t3/4.0d0*lipscale
4898
4899       return
4900       end subroutine eturn3
4901 !-----------------------------------------------------------------------------
4902       subroutine eturn4(i,eello_turn4)
4903 ! Third- and fourth-order contributions from turns
4904
4905       use comm_locel
4906 !      implicit real*8 (a-h,o-z)
4907 !      include 'DIMENSIONS'
4908 !      include 'COMMON.IOUNITS'
4909 !      include 'COMMON.GEO'
4910 !      include 'COMMON.VAR'
4911 !      include 'COMMON.LOCAL'
4912 !      include 'COMMON.CHAIN'
4913 !      include 'COMMON.DERIV'
4914 !      include 'COMMON.INTERACT'
4915 !      include 'COMMON.CONTACTS'
4916 !      include 'COMMON.TORSION'
4917 !      include 'COMMON.VECTORS'
4918 !      include 'COMMON.FFIELD'
4919 !      include 'COMMON.CONTROL'
4920       real(kind=8),dimension(3) :: ggg
4921       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4922         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2,&
4923         gte1t,gte2t,gte3t,&
4924         gte1a,gtae3,gtae3e2, ae3gte2,&
4925         gtEpizda1,gtEpizda2,gtEpizda3
4926
4927       real(kind=8),dimension(2) :: auxvec,auxvec1,auxgEvec1,auxgEvec2,&
4928        auxgEvec3,auxgvec
4929
4930 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4931       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4932 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4933 !el        dz_normi,xmedi,ymedi,zmedi
4934 !el      integer :: num_conti,j1,j2
4935 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4936 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4937 !el          num_conti,j1,j2
4938 !el local variables
4939       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4940       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4941          rlocshield,gs23,gs32,gsE13,gs13,gs21,gsE31,gsEE1,gsEE2,gsEE3,xj,yj
4942       xj=0.0d0
4943       yj=0.0d0
4944       j=i+3
4945 !      if (j.ne.20) return
4946 !      print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1)
4947 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4948 !
4949 !               Fourth-order contributions
4950 !
4951 !                 (i+3)o----(i+4)
4952 !                     /  |
4953 !               (i+2)o   |
4954 !                     \  |
4955 !                 (i+1)o----i
4956 !
4957 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4958 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4959 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4960           zj=(c(3,j)+c(3,j+1))/2.0d0
4961             call to_box(xj,yj,zj)
4962             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
4963
4964
4965         a_temp(1,1)=a22
4966         a_temp(1,2)=a23
4967         a_temp(2,1)=a32
4968         a_temp(2,2)=a33
4969         iti1=i+1
4970         iti2=i+2
4971         iti3=i+3
4972 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4973         call transpose2(EUg(1,1,i+1),e1t(1,1))
4974         call transpose2(Eug(1,1,i+2),e2t(1,1))
4975         call transpose2(Eug(1,1,i+3),e3t(1,1))
4976 !C Ematrix derivative in theta
4977         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
4978         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
4979         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
4980
4981         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4982         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4983         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
4984         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
4985 !c       auxalary matrix of E i+1
4986         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
4987         s1=scalar2(b1(1,iti2),auxvec(1))
4988 !c derivative of theta i+2 with constant i+3
4989         gs23=scalar2(gtb1(1,i+2),auxvec(1))
4990 !c derivative of theta i+2 with constant i+2
4991         gs32=scalar2(b1(1,i+2),auxgvec(1))
4992 !c derivative of E matix in theta of i+1
4993         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
4994
4995         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4996         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
4997         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4998 !c auxilary matrix auxgvec of Ub2 with constant E matirx
4999         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5000 !c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5001         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5002         s2=scalar2(b1(1,i+1),auxvec(1))
5003 !c derivative of theta i+1 with constant i+3
5004         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5005 !c derivative of theta i+2 with constant i+1
5006         gs21=scalar2(b1(1,i+1),auxgvec(1))
5007 !c derivative of theta i+3 with constant i+1
5008         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5009
5010         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5011         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5012 !c ae3gte2 is derivative over i+2
5013         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5014
5015         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5016         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5017 !c i+2
5018         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5019 !c i+3
5020         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5021
5022         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5023         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5024         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5025         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5026         if (shield_mode.eq.0) then
5027         fac_shield(i)=1.0
5028         fac_shield(j)=1.0
5029         endif
5030
5031         eello_turn4=eello_turn4-(s1+s2+s3) &
5032         *fac_shield(i)*fac_shield(j)       &
5033         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5034         eello_t4=-(s1+s2+s3)  &
5035           *fac_shield(i)*fac_shield(j)
5036 !C Now derivative over shield:
5037           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
5038          (shield_mode.gt.0)) then
5039 !C          print *,i,j
5040
5041           do ilist=1,ishield_list(i)
5042            iresshield=shield_list(ilist,i)
5043            do k=1,3
5044            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5045 !           print *,"rlocshield",rlocshield,grad_shield_side(k,ilist,i),iresshield
5046            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5047                    rlocshield &
5048             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5049             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5050            +rlocshield
5051            enddo
5052           enddo
5053           do ilist=1,ishield_list(j)
5054            iresshield=shield_list(ilist,j)
5055            do k=1,3
5056 !           print *,"rlocshieldj",j,rlocshield,grad_shield_side(k,ilist,j),iresshield
5057            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5058            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
5059                    rlocshield  &
5060            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5061            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
5062                   +rlocshield
5063 !            print *,"after", gshieldc_t4(k,iresshield-1),iresshield-1,gshieldc_t4(k,iresshield)
5064
5065            enddo
5066           enddo
5067           do k=1,3
5068             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
5069                    grad_shield(k,i)*eello_t4/fac_shield(i)
5070             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
5071                    grad_shield(k,j)*eello_t4/fac_shield(j)
5072             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
5073                    grad_shield(k,i)*eello_t4/fac_shield(i)
5074             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
5075                    grad_shield(k,j)*eello_t4/fac_shield(j)
5076 !           print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1)
5077            enddo
5078            endif
5079 #ifdef NEWCORR
5080         gloc(nphi+i,icg)=gloc(nphi+i,icg)&
5081                        -(gs13+gsE13+gsEE1)*wturn4&
5082        *fac_shield(i)*fac_shield(j) &
5083        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5084
5085         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)&
5086                          -(gs23+gs21+gsEE2)*wturn4&
5087        *fac_shield(i)*fac_shield(j)&
5088        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5089
5090         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)&
5091                          -(gs32+gsE31+gsEE3)*wturn4&
5092        *fac_shield(i)*fac_shield(j)&
5093        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5094
5095
5096 !c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5097 !c     &   gs2
5098 #endif
5099         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5100            'eturn4',i,j,-(s1+s2+s3)
5101 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5102 !d     &    ' eello_turn4_num',8*eello_turn4_num
5103 ! Derivatives in gamma(i)
5104         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5105         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5106         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5107         s1=scalar2(b1(1,i+1),auxvec(1))
5108         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5109         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5110         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
5111        *fac_shield(i)*fac_shield(j)  &
5112        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5113
5114 ! Derivatives in gamma(i+1)
5115         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5116         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5117         s2=scalar2(b1(1,iti1),auxvec(1))
5118         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5119         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5120         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5121         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
5122        *fac_shield(i)*fac_shield(j)  &
5123        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5124
5125 ! Derivatives in gamma(i+2)
5126         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5127         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5128         s1=scalar2(b1(1,iti2),auxvec(1))
5129         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5130         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5131         s2=scalar2(b1(1,iti1),auxvec(1))
5132         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5133         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5134         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5135         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
5136        *fac_shield(i)*fac_shield(j)  &
5137        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5138
5139 ! Cartesian derivatives
5140 ! Derivatives of this turn contributions in DC(i+2)
5141         if (j.lt.nres-1) then
5142           do l=1,3
5143             a_temp(1,1)=agg(l,1)
5144             a_temp(1,2)=agg(l,2)
5145             a_temp(2,1)=agg(l,3)
5146             a_temp(2,2)=agg(l,4)
5147             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5148             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5149             s1=scalar2(b1(1,iti2),auxvec(1))
5150             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5151             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5152             s2=scalar2(b1(1,iti1),auxvec(1))
5153             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5154             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5155             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5156             ggg(l)=-(s1+s2+s3)
5157             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
5158        *fac_shield(i)*fac_shield(j)  &
5159        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5160
5161           enddo
5162         endif
5163 ! Remaining derivatives of this turn contribution
5164         do l=1,3
5165           a_temp(1,1)=aggi(l,1)
5166           a_temp(1,2)=aggi(l,2)
5167           a_temp(2,1)=aggi(l,3)
5168           a_temp(2,2)=aggi(l,4)
5169           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5170           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5171           s1=scalar2(b1(1,iti2),auxvec(1))
5172           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5173           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5174           s2=scalar2(b1(1,iti1),auxvec(1))
5175           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5176           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5177           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5178           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
5179          *fac_shield(i)*fac_shield(j)  &
5180          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5181
5182
5183           a_temp(1,1)=aggi1(l,1)
5184           a_temp(1,2)=aggi1(l,2)
5185           a_temp(2,1)=aggi1(l,3)
5186           a_temp(2,2)=aggi1(l,4)
5187           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5188           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5189           s1=scalar2(b1(1,iti2),auxvec(1))
5190           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5191           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5192           s2=scalar2(b1(1,iti1),auxvec(1))
5193           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5194           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5195           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5196           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
5197          *fac_shield(i)*fac_shield(j)  &
5198          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5199
5200
5201           a_temp(1,1)=aggj(l,1)
5202           a_temp(1,2)=aggj(l,2)
5203           a_temp(2,1)=aggj(l,3)
5204           a_temp(2,2)=aggj(l,4)
5205           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5206           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5207           s1=scalar2(b1(1,iti2),auxvec(1))
5208           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5209           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5210           s2=scalar2(b1(1,iti1),auxvec(1))
5211           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5212           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5213           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5214 !        if (j.lt.nres-1) then
5215           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
5216          *fac_shield(i)*fac_shield(j)  &
5217          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5218 !        endif
5219
5220           a_temp(1,1)=aggj1(l,1)
5221           a_temp(1,2)=aggj1(l,2)
5222           a_temp(2,1)=aggj1(l,3)
5223           a_temp(2,2)=aggj1(l,4)
5224           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5225           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5226           s1=scalar2(b1(1,iti2),auxvec(1))
5227           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5228           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5229           s2=scalar2(b1(1,iti1),auxvec(1))
5230           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5231           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5232           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5233 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5234 !        if (j.lt.nres-1) then
5235 !          print *,"juest before",j1, gcorr4_turn(l,j1)
5236           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
5237          *fac_shield(i)*fac_shield(j)  &
5238          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
5239 !            if (shield_mode.gt.0) then
5240 !             print *,"juest after",j1, gcorr4_turn(l,j1),gshieldc_t4(k,j1),gshieldc_loc_t4(k,j1),gel_loc_turn4(i+2)
5241 !            else
5242 !             print *,"juest after",j1, gcorr4_turn(l,j1),gel_loc_turn4(i+2)
5243 !            endif
5244 !         endif
5245         enddo
5246          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
5247           ssgradlipi*eello_t4/4.0d0*lipscale
5248          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
5249           ssgradlipj*eello_t4/4.0d0*lipscale
5250          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
5251           ssgradlipi*eello_t4/4.0d0*lipscale
5252          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
5253           ssgradlipj*eello_t4/4.0d0*lipscale
5254
5255       return
5256       end subroutine eturn4
5257 !-----------------------------------------------------------------------------
5258       subroutine unormderiv(u,ugrad,unorm,ungrad)
5259 ! This subroutine computes the derivatives of a normalized vector u, given
5260 ! the derivatives computed without normalization conditions, ugrad. Returns
5261 ! ungrad.
5262 !      implicit none
5263       real(kind=8),dimension(3) :: u,vec
5264       real(kind=8),dimension(3,3) ::ugrad,ungrad
5265       real(kind=8) :: unorm      !,scalar
5266       integer :: i,j
5267 !      write (2,*) 'ugrad',ugrad
5268 !      write (2,*) 'u',u
5269       do i=1,3
5270         vec(i)=scalar(ugrad(1,i),u(1))
5271       enddo
5272 !      write (2,*) 'vec',vec
5273       do i=1,3
5274         do j=1,3
5275           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5276         enddo
5277       enddo
5278 !      write (2,*) 'ungrad',ungrad
5279       return
5280       end subroutine unormderiv
5281 !-----------------------------------------------------------------------------
5282       subroutine escp_soft_sphere(evdw2,evdw2_14)
5283 !
5284 ! This subroutine calculates the excluded-volume interaction energy between
5285 ! peptide-group centers and side chains and its gradient in virtual-bond and
5286 ! side-chain vectors.
5287 !
5288 !      implicit real*8 (a-h,o-z)
5289 !      include 'DIMENSIONS'
5290 !      include 'COMMON.GEO'
5291 !      include 'COMMON.VAR'
5292 !      include 'COMMON.LOCAL'
5293 !      include 'COMMON.CHAIN'
5294 !      include 'COMMON.DERIV'
5295 !      include 'COMMON.INTERACT'
5296 !      include 'COMMON.FFIELD'
5297 !      include 'COMMON.IOUNITS'
5298 !      include 'COMMON.CONTROL'
5299       real(kind=8),dimension(3) :: ggg
5300 !el local variables
5301       integer :: i,iint,j,k,iteli,itypj
5302       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
5303                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
5304
5305       evdw2=0.0D0
5306       evdw2_14=0.0d0
5307       r0_scp=4.5d0
5308 !d    print '(a)','Enter ESCP'
5309 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5310       do i=iatscp_s,iatscp_e
5311         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5312         iteli=itel(i)
5313         xi=0.5D0*(c(1,i)+c(1,i+1))
5314         yi=0.5D0*(c(2,i)+c(2,i+1))
5315         zi=0.5D0*(c(3,i)+c(3,i+1))
5316           call to_box(xi,yi,zi)
5317
5318         do iint=1,nscp_gr(i)
5319
5320         do j=iscpstart(i,iint),iscpend(i,iint)
5321           if (itype(j,1).eq.ntyp1) cycle
5322           itypj=iabs(itype(j,1))
5323 ! Uncomment following three lines for SC-p interactions
5324 !         xj=c(1,nres+j)-xi
5325 !         yj=c(2,nres+j)-yi
5326 !         zj=c(3,nres+j)-zi
5327 ! Uncomment following three lines for Ca-p interactions
5328           xj=c(1,j)-xi
5329           yj=c(2,j)-yi
5330           zj=c(3,j)-zi
5331           call to_box(xj,yj,zj)
5332           xj=boxshift(xj-xi,boxxsize)
5333           yj=boxshift(yj-yi,boxysize)
5334           zj=boxshift(zj-zi,boxzsize)
5335           rij=xj*xj+yj*yj+zj*zj
5336           r0ij=r0_scp
5337           r0ijsq=r0ij*r0ij
5338           if (rij.lt.r0ijsq) then
5339             evdwij=0.25d0*(rij-r0ijsq)**2
5340             fac=rij-r0ijsq
5341           else
5342             evdwij=0.0d0
5343             fac=0.0d0
5344           endif
5345           evdw2=evdw2+evdwij
5346 !
5347 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5348 !
5349           ggg(1)=xj*fac
5350           ggg(2)=yj*fac
5351           ggg(3)=zj*fac
5352 !grad          if (j.lt.i) then
5353 !d          write (iout,*) 'j<i'
5354 ! Uncomment following three lines for SC-p interactions
5355 !           do k=1,3
5356 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5357 !           enddo
5358 !grad          else
5359 !d          write (iout,*) 'j>i'
5360 !grad            do k=1,3
5361 !grad              ggg(k)=-ggg(k)
5362 ! Uncomment following line for SC-p interactions
5363 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5364 !grad            enddo
5365 !grad          endif
5366 !grad          do k=1,3
5367 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5368 !grad          enddo
5369 !grad          kstart=min0(i+1,j)
5370 !grad          kend=max0(i-1,j-1)
5371 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5372 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5373 !grad          do k=kstart,kend
5374 !grad            do l=1,3
5375 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5376 !grad            enddo
5377 !grad          enddo
5378           do k=1,3
5379             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5380             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5381           enddo
5382         enddo
5383
5384         enddo ! iint
5385       enddo ! i
5386       return
5387       end subroutine escp_soft_sphere
5388 !-----------------------------------------------------------------------------
5389       subroutine escp(evdw2,evdw2_14)
5390 !
5391 ! This subroutine calculates the excluded-volume interaction energy between
5392 ! peptide-group centers and side chains and its gradient in virtual-bond and
5393 ! side-chain vectors.
5394 !
5395 !      implicit real*8 (a-h,o-z)
5396 !      include 'DIMENSIONS'
5397 !      include 'COMMON.GEO'
5398 !      include 'COMMON.VAR'
5399 !      include 'COMMON.LOCAL'
5400 !      include 'COMMON.CHAIN'
5401 !      include 'COMMON.DERIV'
5402 !      include 'COMMON.INTERACT'
5403 !      include 'COMMON.FFIELD'
5404 !      include 'COMMON.IOUNITS'
5405 !      include 'COMMON.CONTROL'
5406       real(kind=8),dimension(3) :: ggg
5407 !el local variables
5408       integer :: i,iint,j,k,iteli,itypj,subchap,icont
5409       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
5410                    e1,e2,evdwij,rij
5411       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
5412                     dist_temp, dist_init
5413       integer xshift,yshift,zshift
5414
5415       evdw2=0.0D0
5416       evdw2_14=0.0d0
5417 !d    print '(a)','Enter ESCP'
5418 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5419 !      do i=iatscp_s,iatscp_e
5420       if (nres_molec(1).eq.0) return
5421        do icont=g_listscp_start,g_listscp_end
5422         i=newcontlistscpi(icont)
5423         j=newcontlistscpj(icont)
5424         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5425         iteli=itel(i)
5426         xi=0.5D0*(c(1,i)+c(1,i+1))
5427         yi=0.5D0*(c(2,i)+c(2,i+1))
5428         zi=0.5D0*(c(3,i)+c(3,i+1))
5429         call to_box(xi,yi,zi)
5430
5431 !        do iint=1,nscp_gr(i)
5432
5433 !        do j=iscpstart(i,iint),iscpend(i,iint)
5434           itypj=iabs(itype(j,1))
5435           if (itypj.eq.ntyp1) cycle
5436 ! Uncomment following three lines for SC-p interactions
5437 !         xj=c(1,nres+j)-xi
5438 !         yj=c(2,nres+j)-yi
5439 !         zj=c(3,nres+j)-zi
5440 ! Uncomment following three lines for Ca-p interactions
5441 !          xj=c(1,j)-xi
5442 !          yj=c(2,j)-yi
5443 !          zj=c(3,j)-zi
5444           xj=c(1,j)
5445           yj=c(2,j)
5446           zj=c(3,j)
5447
5448           call to_box(xj,yj,zj)
5449           xj=boxshift(xj-xi,boxxsize)
5450           yj=boxshift(yj-yi,boxysize)
5451           zj=boxshift(zj-zi,boxzsize)
5452
5453           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5454           rij=dsqrt(1.0d0/rrij)
5455             sss_ele_cut=sscale_ele(rij)
5456             sss_ele_grad=sscagrad_ele(rij)
5457 !            print *,sss_ele_cut,sss_ele_grad,&
5458 !            (rij),r_cut_ele,rlamb_ele
5459             if (sss_ele_cut.le.0.0) cycle
5460           fac=rrij**expon2
5461           e1=fac*fac*aad(itypj,iteli)
5462           e2=fac*bad(itypj,iteli)
5463           if (iabs(j-i) .le. 2) then
5464             e1=scal14*e1
5465             e2=scal14*e2
5466             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5467           endif
5468           evdwij=e1+e2
5469           evdw2=evdw2+evdwij*sss_ele_cut
5470 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5471 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5472           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5473              'evdw2',i,j,evdwij
5474 !
5475 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5476 !
5477           fac=-(evdwij+e1)*rrij*sss_ele_cut
5478           fac=fac+evdwij*sss_ele_grad/rij/expon
5479           ggg(1)=xj*fac
5480           ggg(2)=yj*fac
5481           ggg(3)=zj*fac
5482 !grad          if (j.lt.i) then
5483 !d          write (iout,*) 'j<i'
5484 ! Uncomment following three lines for SC-p interactions
5485 !           do k=1,3
5486 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5487 !           enddo
5488 !grad          else
5489 !d          write (iout,*) 'j>i'
5490 !grad            do k=1,3
5491 !grad              ggg(k)=-ggg(k)
5492 ! Uncomment following line for SC-p interactions
5493 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5494 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5495 !grad            enddo
5496 !grad          endif
5497 !grad          do k=1,3
5498 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5499 !grad          enddo
5500 !grad          kstart=min0(i+1,j)
5501 !grad          kend=max0(i-1,j-1)
5502 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5503 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5504 !grad          do k=kstart,kend
5505 !grad            do l=1,3
5506 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5507 !grad            enddo
5508 !grad          enddo
5509           do k=1,3
5510             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5511             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5512           enddo
5513 !        enddo
5514
5515 !        enddo ! iint
5516       enddo ! i
5517       do i=1,nct
5518         do j=1,3
5519           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5520           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5521           gradx_scp(j,i)=expon*gradx_scp(j,i)
5522         enddo
5523       enddo
5524 !******************************************************************************
5525 !
5526 !                              N O T E !!!
5527 !
5528 ! To save time the factor EXPON has been extracted from ALL components
5529 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5530 ! use!
5531 !
5532 !******************************************************************************
5533       return
5534       end subroutine escp
5535 !-----------------------------------------------------------------------------
5536       subroutine edis(ehpb)
5537 !
5538 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5539 !
5540 !      implicit real*8 (a-h,o-z)
5541 !      include 'DIMENSIONS'
5542 !      include 'COMMON.SBRIDGE'
5543 !      include 'COMMON.CHAIN'
5544 !      include 'COMMON.DERIV'
5545 !      include 'COMMON.VAR'
5546 !      include 'COMMON.INTERACT'
5547 !      include 'COMMON.IOUNITS'
5548       real(kind=8),dimension(3) :: ggg
5549 !el local variables
5550       integer :: i,j,ii,jj,iii,jjj,k
5551       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5552
5553       ehpb=0.0D0
5554 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5555 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5556       if (link_end.eq.0) return
5557       do i=link_start,link_end
5558 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5559 ! CA-CA distance used in regularization of structure.
5560         ii=ihpb(i)
5561         jj=jhpb(i)
5562 ! iii and jjj point to the residues for which the distance is assigned.
5563         if (ii.gt.nres) then
5564           iii=ii-nres
5565           jjj=jj-nres
5566         else
5567           iii=ii
5568           jjj=jj
5569         endif
5570 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5571 !     &    dhpb(i),dhpb1(i),forcon(i)
5572 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5573 !    distance and angle dependent SS bond potential.
5574 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5575 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5576         if (.not.dyn_ss .and. i.le.nss) then
5577 ! 15/02/13 CC dynamic SSbond - additional check
5578          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5579         iabs(itype(jjj,1)).eq.1) then
5580           call ssbond_ene(iii,jjj,eij)
5581           ehpb=ehpb+2*eij
5582 !          write (iout,*) "eij",eij,iii,jjj
5583          endif
5584         else if (ii.gt.nres .and. jj.gt.nres) then
5585 !c Restraints from contact prediction
5586           dd=dist(ii,jj)
5587           if (constr_dist.eq.11) then
5588             ehpb=ehpb+fordepth(i)**4.0d0 &
5589                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5590             fac=fordepth(i)**4.0d0 &
5591                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5592           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5593             ehpb,fordepth(i),dd
5594            else
5595           if (dhpb1(i).gt.0.0d0) then
5596             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5597             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5598 !c            write (iout,*) "beta nmr",
5599 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5600           else
5601             dd=dist(ii,jj)
5602             rdis=dd-dhpb(i)
5603 !C Get the force constant corresponding to this distance.
5604             waga=forcon(i)
5605 !C Calculate the contribution to energy.
5606             ehpb=ehpb+waga*rdis*rdis
5607 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5608 !C
5609 !C Evaluate gradient.
5610 !C
5611             fac=waga*rdis/dd
5612           endif
5613           endif
5614           do j=1,3
5615             ggg(j)=fac*(c(j,jj)-c(j,ii))
5616           enddo
5617           do j=1,3
5618             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5619             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5620           enddo
5621           do k=1,3
5622             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5623             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5624           enddo
5625         else
5626           dd=dist(ii,jj)
5627           if (constr_dist.eq.11) then
5628             ehpb=ehpb+fordepth(i)**4.0d0 &
5629                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5630             fac=fordepth(i)**4.0d0 &
5631                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5632           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5633          ehpb,fordepth(i),dd
5634            else
5635           if (dhpb1(i).gt.0.0d0) then
5636             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5637             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5638 !c            write (iout,*) "alph nmr",
5639 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5640           else
5641             rdis=dd-dhpb(i)
5642 !C Get the force constant corresponding to this distance.
5643             waga=forcon(i)
5644 !C Calculate the contribution to energy.
5645             ehpb=ehpb+waga*rdis*rdis
5646 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5647 !C
5648 !C Evaluate gradient.
5649 !C
5650             fac=waga*rdis/dd
5651           endif
5652           endif
5653
5654             do j=1,3
5655               ggg(j)=fac*(c(j,jj)-c(j,ii))
5656             enddo
5657 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5658 !C If this is a SC-SC distance, we need to calculate the contributions to the
5659 !C Cartesian gradient in the SC vectors (ghpbx).
5660           if (iii.lt.ii) then
5661           do j=1,3
5662             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5663             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5664           enddo
5665           endif
5666 !cgrad        do j=iii,jjj-1
5667 !cgrad          do k=1,3
5668 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5669 !cgrad          enddo
5670 !cgrad        enddo
5671           do k=1,3
5672             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5673             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5674           enddo
5675         endif
5676       enddo
5677       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5678
5679       return
5680       end subroutine edis
5681 !-----------------------------------------------------------------------------
5682       subroutine ssbond_ene(i,j,eij)
5683 !
5684 ! Calculate the distance and angle dependent SS-bond potential energy
5685 ! using a free-energy function derived based on RHF/6-31G** ab initio
5686 ! calculations of diethyl disulfide.
5687 !
5688 ! A. Liwo and U. Kozlowska, 11/24/03
5689 !
5690 !      implicit real*8 (a-h,o-z)
5691 !      include 'DIMENSIONS'
5692 !      include 'COMMON.SBRIDGE'
5693 !      include 'COMMON.CHAIN'
5694 !      include 'COMMON.DERIV'
5695 !      include 'COMMON.LOCAL'
5696 !      include 'COMMON.INTERACT'
5697 !      include 'COMMON.VAR'
5698 !      include 'COMMON.IOUNITS'
5699       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5700 !el local variables
5701       integer :: i,j,itypi,itypj,k
5702       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5703                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5704                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5705                    cosphi,ggk
5706
5707       itypi=iabs(itype(i,1))
5708       xi=c(1,nres+i)
5709       yi=c(2,nres+i)
5710       zi=c(3,nres+i)
5711           call to_box(xi,yi,zi)
5712
5713       dxi=dc_norm(1,nres+i)
5714       dyi=dc_norm(2,nres+i)
5715       dzi=dc_norm(3,nres+i)
5716 !      dsci_inv=dsc_inv(itypi)
5717       dsci_inv=vbld_inv(nres+i)
5718       itypj=iabs(itype(j,1))
5719 !      dscj_inv=dsc_inv(itypj)
5720       dscj_inv=vbld_inv(nres+j)
5721       xj=c(1,nres+j)
5722       yj=c(2,nres+j)
5723       zj=c(3,nres+j)
5724           call to_box(xj,yj,zj)
5725       xj=boxshift(xj-xi,boxxsize)
5726       yj=boxshift(yj-yi,boxysize)
5727       zj=boxshift(zj-zi,boxzsize)
5728       dxj=dc_norm(1,nres+j)
5729       dyj=dc_norm(2,nres+j)
5730       dzj=dc_norm(3,nres+j)
5731       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5732       rij=dsqrt(rrij)
5733       erij(1)=xj*rij
5734       erij(2)=yj*rij
5735       erij(3)=zj*rij
5736       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5737       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5738       om12=dxi*dxj+dyi*dyj+dzi*dzj
5739       do k=1,3
5740         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5741         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5742       enddo
5743       rij=1.0d0/rij
5744       deltad=rij-d0cm
5745       deltat1=1.0d0-om1
5746       deltat2=1.0d0+om2
5747       deltat12=om2-om1+2.0d0
5748       cosphi=om12-om1*om2
5749       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5750         +akct*deltad*deltat12 &
5751         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5752 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth, &
5753 !       " akct",akct," deltad",deltad," deltat",deltat1,deltat2, &
5754 !       " deltat12",deltat12," eij",eij
5755       ed=2*akcm*deltad+akct*deltat12
5756       pom1=akct*deltad
5757       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5758       eom1=-2*akth*deltat1-pom1-om2*pom2
5759       eom2= 2*akth*deltat2+pom1-om1*pom2
5760       eom12=pom2
5761       do k=1,3
5762         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5763         ghpbx(k,i)=ghpbx(k,i)-ggk &
5764                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5765                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5766         ghpbx(k,j)=ghpbx(k,j)+ggk &
5767                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5768                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5769         ghpbc(k,i)=ghpbc(k,i)-ggk
5770         ghpbc(k,j)=ghpbc(k,j)+ggk
5771       enddo
5772 !
5773 ! Calculate the components of the gradient in DC and X
5774 !
5775 !grad      do k=i,j-1
5776 !grad        do l=1,3
5777 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5778 !grad        enddo
5779 !grad      enddo
5780       return
5781       end subroutine ssbond_ene
5782 !-----------------------------------------------------------------------------
5783       subroutine ebond(estr)
5784 !
5785 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5786 !
5787 !      implicit real*8 (a-h,o-z)
5788 !      include 'DIMENSIONS'
5789 !      include 'COMMON.LOCAL'
5790 !      include 'COMMON.GEO'
5791 !      include 'COMMON.INTERACT'
5792 !      include 'COMMON.DERIV'
5793 !      include 'COMMON.VAR'
5794 !      include 'COMMON.CHAIN'
5795 !      include 'COMMON.IOUNITS'
5796 !      include 'COMMON.NAMES'
5797 !      include 'COMMON.FFIELD'
5798 !      include 'COMMON.CONTROL'
5799 !      include 'COMMON.SETUP'
5800       real(kind=8),dimension(3) :: u,ud
5801 !el local variables
5802       integer :: i,j,iti,nbi,k
5803       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5804                    uprod1,uprod2
5805
5806       estr=0.0d0
5807       estr1=0.0d0
5808 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5809 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5810
5811       do i=ibondp_start,ibondp_end
5812         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5813         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5814 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5815 !C          do j=1,3
5816 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5817 !C            *dc(j,i-1)/vbld(i)
5818 !C          enddo
5819 !C          if (energy_dec) write(iout,*) &
5820 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5821         diff = vbld(i)-vbldpDUM
5822         else
5823         diff = vbld(i)-vbldp0
5824         endif
5825         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5826            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5827         estr=estr+diff*diff
5828         do j=1,3
5829           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5830         enddo
5831 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5832 !        endif
5833       enddo
5834       estr=0.5d0*AKP*estr+estr1
5835 !      print *,"estr_bb",estr,AKP
5836 !
5837 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5838 !
5839       do i=ibond_start,ibond_end
5840         iti=iabs(itype(i,1))
5841         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5842         if (iti.ne.10 .and. iti.ne.ntyp1) then
5843           nbi=nbondterm(iti)
5844           if (nbi.eq.1) then
5845             diff=vbld(i+nres)-vbldsc0(1,iti)
5846             if (energy_dec) write (iout,*) &
5847             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5848             AKSC(1,iti),AKSC(1,iti)*diff*diff
5849             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5850 !            print *,"estr_sc",estr
5851             do j=1,3
5852               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5853             enddo
5854           else
5855             do j=1,nbi
5856               diff=vbld(i+nres)-vbldsc0(j,iti)
5857               ud(j)=aksc(j,iti)*diff
5858               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5859             enddo
5860             uprod=u(1)
5861             do j=2,nbi
5862               uprod=uprod*u(j)
5863             enddo
5864             usum=0.0d0
5865             usumsqder=0.0d0
5866             do j=1,nbi
5867               uprod1=1.0d0
5868               uprod2=1.0d0
5869               do k=1,nbi
5870                 if (k.ne.j) then
5871                   uprod1=uprod1*u(k)
5872                   uprod2=uprod2*u(k)*u(k)
5873                 endif
5874               enddo
5875               usum=usum+uprod1
5876               usumsqder=usumsqder+ud(j)*uprod2
5877             enddo
5878             estr=estr+uprod/usum
5879 !            print *,"estr_sc",estr,i
5880
5881              if (energy_dec) write (iout,*) &
5882             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5883             AKSC(1,iti),uprod/usum
5884             do j=1,3
5885              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5886             enddo
5887           endif
5888         endif
5889       enddo
5890       return
5891       end subroutine ebond
5892 #ifdef CRYST_THETA
5893 !-----------------------------------------------------------------------------
5894       subroutine ebend(etheta)
5895 !
5896 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5897 ! angles gamma and its derivatives in consecutive thetas and gammas.
5898 !
5899       use comm_calcthet
5900 !      implicit real*8 (a-h,o-z)
5901 !      include 'DIMENSIONS'
5902 !      include 'COMMON.LOCAL'
5903 !      include 'COMMON.GEO'
5904 !      include 'COMMON.INTERACT'
5905 !      include 'COMMON.DERIV'
5906 !      include 'COMMON.VAR'
5907 !      include 'COMMON.CHAIN'
5908 !      include 'COMMON.IOUNITS'
5909 !      include 'COMMON.NAMES'
5910 !      include 'COMMON.FFIELD'
5911 !      include 'COMMON.CONTROL'
5912 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5913 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5914 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5915 !el      integer :: it
5916 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5917 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5918 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5919 !el local variables
5920       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5921        ichir21,ichir22
5922       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5923        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5924        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5925       real(kind=8),dimension(2) :: y,z
5926
5927       delta=0.02d0*pi
5928 !      time11=dexp(-2*time)
5929 !      time12=1.0d0
5930       etheta=0.0D0
5931 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5932       do i=ithet_start,ithet_end
5933         if (itype(i-1,1).eq.ntyp1) cycle
5934 ! Zero the energy function and its derivative at 0 or pi.
5935         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5936         it=itype(i-1,1)
5937         ichir1=isign(1,itype(i-2,1))
5938         ichir2=isign(1,itype(i,1))
5939          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5940          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5941          if (itype(i-1,1).eq.10) then
5942           itype1=isign(10,itype(i-2,1))
5943           ichir11=isign(1,itype(i-2,1))
5944           ichir12=isign(1,itype(i-2,1))
5945           itype2=isign(10,itype(i,1))
5946           ichir21=isign(1,itype(i,1))
5947           ichir22=isign(1,itype(i,1))
5948          endif
5949
5950         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5951 #ifdef OSF
5952           phii=phi(i)
5953           if (phii.ne.phii) phii=150.0
5954 #else
5955           phii=phi(i)
5956 #endif
5957           y(1)=dcos(phii)
5958           y(2)=dsin(phii)
5959         else
5960           y(1)=0.0D0
5961           y(2)=0.0D0
5962         endif
5963         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5964 #ifdef OSF
5965           phii1=phi(i+1)
5966           if (phii1.ne.phii1) phii1=150.0
5967           phii1=pinorm(phii1)
5968           z(1)=cos(phii1)
5969 #else
5970           phii1=phi(i+1)
5971           z(1)=dcos(phii1)
5972 #endif
5973           z(2)=dsin(phii1)
5974         else
5975           z(1)=0.0D0
5976           z(2)=0.0D0
5977         endif
5978 ! Calculate the "mean" value of theta from the part of the distribution
5979 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5980 ! In following comments this theta will be referred to as t_c.
5981         thet_pred_mean=0.0d0
5982         do k=1,2
5983             athetk=athet(k,it,ichir1,ichir2)
5984             bthetk=bthet(k,it,ichir1,ichir2)
5985           if (it.eq.10) then
5986              athetk=athet(k,itype1,ichir11,ichir12)
5987              bthetk=bthet(k,itype2,ichir21,ichir22)
5988           endif
5989          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5990         enddo
5991         dthett=thet_pred_mean*ssd
5992         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5993 ! Derivatives of the "mean" values in gamma1 and gamma2.
5994         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5995                +athet(2,it,ichir1,ichir2)*y(1))*ss
5996         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5997                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5998          if (it.eq.10) then
5999         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
6000              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
6001         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
6002                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6003          endif
6004         if (theta(i).gt.pi-delta) then
6005           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
6006                E_tc0)
6007           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6008           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6009           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
6010               E_theta)
6011           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
6012               E_tc)
6013         else if (theta(i).lt.delta) then
6014           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6015           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6016           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
6017               E_theta)
6018           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6019           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
6020               E_tc)
6021         else
6022           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
6023               E_theta,E_tc)
6024         endif
6025         etheta=etheta+ethetai
6026         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6027             'ebend',i,ethetai
6028         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6029         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6030         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6031       enddo
6032 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6033
6034 ! Ufff.... We've done all this!!!
6035       return
6036       end subroutine ebend
6037 !-----------------------------------------------------------------------------
6038       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
6039
6040       use comm_calcthet
6041 !      implicit real*8 (a-h,o-z)
6042 !      include 'DIMENSIONS'
6043 !      include 'COMMON.LOCAL'
6044 !      include 'COMMON.IOUNITS'
6045 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
6046 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6047 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
6048       integer :: i,j,k
6049       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
6050 !el      integer :: it
6051 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
6052 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
6053 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6054 !el local variables
6055       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
6056        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6057
6058 ! Calculate the contributions to both Gaussian lobes.
6059 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6060 ! The "polynomial part" of the "standard deviation" of this part of
6061 ! the distribution.
6062         sig=polthet(3,it)
6063         do j=2,0,-1
6064           sig=sig*thet_pred_mean+polthet(j,it)
6065         enddo
6066 ! Derivative of the "interior part" of the "standard deviation of the"
6067 ! gamma-dependent Gaussian lobe in t_c.
6068         sigtc=3*polthet(3,it)
6069         do j=2,1,-1
6070           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6071         enddo
6072         sigtc=sig*sigtc
6073 ! Set the parameters of both Gaussian lobes of the distribution.
6074 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6075         fac=sig*sig+sigc0(it)
6076         sigcsq=fac+fac
6077         sigc=1.0D0/sigcsq
6078 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6079         sigsqtc=-4.0D0*sigcsq*sigtc
6080 !       print *,i,sig,sigtc,sigsqtc
6081 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
6082         sigtc=-sigtc/(fac*fac)
6083 ! Following variable is sigma(t_c)**(-2)
6084         sigcsq=sigcsq*sigcsq
6085         sig0i=sig0(it)
6086         sig0inv=1.0D0/sig0i**2
6087         delthec=thetai-thet_pred_mean
6088         delthe0=thetai-theta0i
6089         term1=-0.5D0*sigcsq*delthec*delthec
6090         term2=-0.5D0*sig0inv*delthe0*delthe0
6091 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6092 ! NaNs in taking the logarithm. We extract the largest exponent which is added
6093 ! to the energy (this being the log of the distribution) at the end of energy
6094 ! term evaluation for this virtual-bond angle.
6095         if (term1.gt.term2) then
6096           termm=term1
6097           term2=dexp(term2-termm)
6098           term1=1.0d0
6099         else
6100           termm=term2
6101           term1=dexp(term1-termm)
6102           term2=1.0d0
6103         endif
6104 ! The ratio between the gamma-independent and gamma-dependent lobes of
6105 ! the distribution is a Gaussian function of thet_pred_mean too.
6106         diffak=gthet(2,it)-thet_pred_mean
6107         ratak=diffak/gthet(3,it)**2
6108         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6109 ! Let's differentiate it in thet_pred_mean NOW.
6110         aktc=ak*ratak
6111 ! Now put together the distribution terms to make complete distribution.
6112         termexp=term1+ak*term2
6113         termpre=sigc+ak*sig0i
6114 ! Contribution of the bending energy from this theta is just the -log of
6115 ! the sum of the contributions from the two lobes and the pre-exponential
6116 ! factor. Simple enough, isn't it?
6117         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6118 ! NOW the derivatives!!!
6119 ! 6/6/97 Take into account the deformation.
6120         E_theta=(delthec*sigcsq*term1 &
6121              +ak*delthe0*sig0inv*term2)/termexp
6122         E_tc=((sigtc+aktc*sig0i)/termpre &
6123             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
6124              aktc*term2)/termexp)
6125       return
6126       end subroutine theteng
6127 #else
6128 !-----------------------------------------------------------------------------
6129       subroutine ebend(etheta)
6130 !
6131 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6132 ! angles gamma and its derivatives in consecutive thetas and gammas.
6133 ! ab initio-derived potentials from
6134 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6135 !
6136 !      implicit real*8 (a-h,o-z)
6137 !      include 'DIMENSIONS'
6138 !      include 'COMMON.LOCAL'
6139 !      include 'COMMON.GEO'
6140 !      include 'COMMON.INTERACT'
6141 !      include 'COMMON.DERIV'
6142 !      include 'COMMON.VAR'
6143 !      include 'COMMON.CHAIN'
6144 !      include 'COMMON.IOUNITS'
6145 !      include 'COMMON.NAMES'
6146 !      include 'COMMON.FFIELD'
6147 !      include 'COMMON.CONTROL'
6148       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
6149       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
6150       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
6151       logical :: lprn=.false., lprn1=.false.
6152 !el local variables
6153       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
6154       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
6155       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
6156 ! local variables for constrains
6157       real(kind=8) :: difi,thetiii
6158        integer itheta
6159 !      write(iout,*) "in ebend",ithet_start,ithet_end
6160       call flush(iout)
6161       etheta=0.0D0
6162       do i=ithet_start,ithet_end
6163         if (itype(i-1,1).eq.ntyp1) cycle
6164         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
6165         if (iabs(itype(i+1,1)).eq.20) iblock=2
6166         if (iabs(itype(i+1,1)).ne.20) iblock=1
6167         dethetai=0.0d0
6168         dephii=0.0d0
6169         dephii1=0.0d0
6170         theti2=0.5d0*theta(i)
6171         ityp2=ithetyp((itype(i-1,1)))
6172         do k=1,nntheterm
6173           coskt(k)=dcos(k*theti2)
6174           sinkt(k)=dsin(k*theti2)
6175         enddo
6176         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
6177 #ifdef OSF
6178           phii=phi(i)
6179           if (phii.ne.phii) phii=150.0
6180 #else
6181           phii=phi(i)
6182 #endif
6183           ityp1=ithetyp((itype(i-2,1)))
6184 ! propagation of chirality for glycine type
6185           do k=1,nsingle
6186             cosph1(k)=dcos(k*phii)
6187             sinph1(k)=dsin(k*phii)
6188           enddo
6189         else
6190           phii=0.0d0
6191           ityp1=ithetyp(itype(i-2,1))
6192           do k=1,nsingle
6193             cosph1(k)=0.0d0
6194             sinph1(k)=0.0d0
6195           enddo
6196         endif
6197         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
6198 #ifdef OSF
6199           phii1=phi(i+1)
6200           if (phii1.ne.phii1) phii1=150.0
6201           phii1=pinorm(phii1)
6202 #else
6203           phii1=phi(i+1)
6204 #endif
6205           ityp3=ithetyp((itype(i,1)))
6206           do k=1,nsingle
6207             cosph2(k)=dcos(k*phii1)
6208             sinph2(k)=dsin(k*phii1)
6209           enddo
6210         else
6211           phii1=0.0d0
6212           ityp3=ithetyp(itype(i,1))
6213           do k=1,nsingle
6214             cosph2(k)=0.0d0
6215             sinph2(k)=0.0d0
6216           enddo
6217         endif
6218         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6219         do k=1,ndouble
6220           do l=1,k-1
6221             ccl=cosph1(l)*cosph2(k-l)
6222             ssl=sinph1(l)*sinph2(k-l)
6223             scl=sinph1(l)*cosph2(k-l)
6224             csl=cosph1(l)*sinph2(k-l)
6225             cosph1ph2(l,k)=ccl-ssl
6226             cosph1ph2(k,l)=ccl+ssl
6227             sinph1ph2(l,k)=scl+csl
6228             sinph1ph2(k,l)=scl-csl
6229           enddo
6230         enddo
6231         if (lprn) then
6232         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
6233           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6234         write (iout,*) "coskt and sinkt"
6235         do k=1,nntheterm
6236           write (iout,*) k,coskt(k),sinkt(k)
6237         enddo
6238         endif
6239         do k=1,ntheterm
6240           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6241           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
6242             *coskt(k)
6243           if (lprn) &
6244           write (iout,*) "k",k,&
6245            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
6246            " ethetai",ethetai
6247         enddo
6248         if (lprn) then
6249         write (iout,*) "cosph and sinph"
6250         do k=1,nsingle
6251           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6252         enddo
6253         write (iout,*) "cosph1ph2 and sinph2ph2"
6254         do k=2,ndouble
6255           do l=1,k-1
6256             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
6257                sinph1ph2(l,k),sinph1ph2(k,l)
6258           enddo
6259         enddo
6260         write(iout,*) "ethetai",ethetai
6261         endif
6262         do m=1,ntheterm2
6263           do k=1,nsingle
6264             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
6265                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
6266                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
6267                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6268             ethetai=ethetai+sinkt(m)*aux
6269             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6270             dephii=dephii+k*sinkt(m)* &
6271                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
6272                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6273             dephii1=dephii1+k*sinkt(m)* &
6274                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
6275                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6276             if (lprn) &
6277             write (iout,*) "m",m," k",k," bbthet", &
6278                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
6279                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
6280                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
6281                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6282           enddo
6283         enddo
6284         if (lprn) &
6285         write(iout,*) "ethetai",ethetai
6286         do m=1,ntheterm3
6287           do k=2,ndouble
6288             do l=1,k-1
6289               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6290                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
6291                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6292                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6293               ethetai=ethetai+sinkt(m)*aux
6294               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6295               dephii=dephii+l*sinkt(m)* &
6296                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
6297                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6298                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6299                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6300               dephii1=dephii1+(k-l)*sinkt(m)* &
6301                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6302                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6303                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
6304                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6305               if (lprn) then
6306               write (iout,*) "m",m," k",k," l",l," ffthet",&
6307                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6308                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
6309                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6310                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
6311                   " ethetai",ethetai
6312               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
6313                   cosph1ph2(k,l)*sinkt(m),&
6314                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6315               endif
6316             enddo
6317           enddo
6318         enddo
6319 10      continue
6320 !        lprn1=.true.
6321         if (lprn1) &
6322           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
6323          i,theta(i)*rad2deg,phii*rad2deg,&
6324          phii1*rad2deg,ethetai
6325 !        lprn1=.false.
6326         etheta=etheta+ethetai
6327         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6328                                     'ebend',i,ethetai
6329         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6330         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6331         gloc(nphi+i-2,icg)=wang*dethetai
6332       enddo
6333 !-----------thete constrains
6334 !      if (tor_mode.ne.2) then
6335
6336       return
6337       end subroutine ebend
6338 #endif
6339 #ifdef CRYST_SC
6340 !-----------------------------------------------------------------------------
6341       subroutine esc(escloc)
6342 ! Calculate the local energy of a side chain and its derivatives in the
6343 ! corresponding virtual-bond valence angles THETA and the spherical angles
6344 ! ALPHA and OMEGA.
6345 !
6346       use comm_sccalc
6347 !      implicit real*8 (a-h,o-z)
6348 !      include 'DIMENSIONS'
6349 !      include 'COMMON.GEO'
6350 !      include 'COMMON.LOCAL'
6351 !      include 'COMMON.VAR'
6352 !      include 'COMMON.INTERACT'
6353 !      include 'COMMON.DERIV'
6354 !      include 'COMMON.CHAIN'
6355 !      include 'COMMON.IOUNITS'
6356 !      include 'COMMON.NAMES'
6357 !      include 'COMMON.FFIELD'
6358 !      include 'COMMON.CONTROL'
6359       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
6360          ddersc0,ddummy,xtemp,temp
6361 !el      real(kind=8) :: time11,time12,time112,theti
6362       real(kind=8) :: escloc,delta
6363 !el      integer :: it,nlobit
6364 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6365 !el local variables
6366       integer :: i,k
6367       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
6368        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6369       delta=0.02d0*pi
6370       escloc=0.0D0
6371 !     write (iout,'(a)') 'ESC'
6372       do i=loc_start,loc_end
6373         it=itype(i,1)
6374         if (it.eq.ntyp1) cycle
6375         if (it.eq.10) goto 1
6376         nlobit=nlob(iabs(it))
6377 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
6378 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6379         theti=theta(i+1)-pipol
6380         x(1)=dtan(theti)
6381         x(2)=alph(i)
6382         x(3)=omeg(i)
6383
6384         if (x(2).gt.pi-delta) then
6385           xtemp(1)=x(1)
6386           xtemp(2)=pi-delta
6387           xtemp(3)=x(3)
6388           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6389           xtemp(2)=pi
6390           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6391           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
6392               escloci,dersc(2))
6393           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6394               ddersc0(1),dersc(1))
6395           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
6396               ddersc0(3),dersc(3))
6397           xtemp(2)=pi-delta
6398           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6399           xtemp(2)=pi
6400           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6401           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6402                   dersc0(2),esclocbi,dersc02)
6403           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6404                   dersc12,dersc01)
6405           call splinthet(x(2),0.5d0*delta,ss,ssd)
6406           dersc0(1)=dersc01
6407           dersc0(2)=dersc02
6408           dersc0(3)=0.0d0
6409           do k=1,3
6410             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6411           enddo
6412           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6413 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6414 !    &             esclocbi,ss,ssd
6415           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6416 !         escloci=esclocbi
6417 !         write (iout,*) escloci
6418         else if (x(2).lt.delta) then
6419           xtemp(1)=x(1)
6420           xtemp(2)=delta
6421           xtemp(3)=x(3)
6422           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6423           xtemp(2)=0.0d0
6424           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6425           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6426               escloci,dersc(2))
6427           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6428               ddersc0(1),dersc(1))
6429           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6430               ddersc0(3),dersc(3))
6431           xtemp(2)=delta
6432           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6433           xtemp(2)=0.0d0
6434           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6435           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6436                   dersc0(2),esclocbi,dersc02)
6437           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6438                   dersc12,dersc01)
6439           dersc0(1)=dersc01
6440           dersc0(2)=dersc02
6441           dersc0(3)=0.0d0
6442           call splinthet(x(2),0.5d0*delta,ss,ssd)
6443           do k=1,3
6444             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6445           enddo
6446           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6447 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6448 !    &             esclocbi,ss,ssd
6449           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6450 !         write (iout,*) escloci
6451         else
6452           call enesc(x,escloci,dersc,ddummy,.false.)
6453         endif
6454
6455         escloc=escloc+escloci
6456         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6457            'escloc',i,escloci
6458 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6459
6460         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6461          wscloc*dersc(1)
6462         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6463         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6464     1   continue
6465       enddo
6466       return
6467       end subroutine esc
6468 !-----------------------------------------------------------------------------
6469       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6470
6471       use comm_sccalc
6472 !      implicit real*8 (a-h,o-z)
6473 !      include 'DIMENSIONS'
6474 !      include 'COMMON.GEO'
6475 !      include 'COMMON.LOCAL'
6476 !      include 'COMMON.IOUNITS'
6477 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6478       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6479       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6480       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6481       real(kind=8) :: escloci
6482       logical :: mixed
6483 !el local variables
6484       integer :: j,iii,l,k !el,it,nlobit
6485       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6486 !el       time11,time12,time112
6487 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6488         escloc_i=0.0D0
6489         do j=1,3
6490           dersc(j)=0.0D0
6491           if (mixed) ddersc(j)=0.0d0
6492         enddo
6493         x3=x(3)
6494
6495 ! Because of periodicity of the dependence of the SC energy in omega we have
6496 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6497 ! To avoid underflows, first compute & store the exponents.
6498
6499         do iii=-1,1
6500
6501           x(3)=x3+iii*dwapi
6502
6503           do j=1,nlobit
6504             do k=1,3
6505               z(k)=x(k)-censc(k,j,it)
6506             enddo
6507             do k=1,3
6508               Axk=0.0D0
6509               do l=1,3
6510                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6511               enddo
6512               Ax(k,j,iii)=Axk
6513             enddo
6514             expfac=0.0D0
6515             do k=1,3
6516               expfac=expfac+Ax(k,j,iii)*z(k)
6517             enddo
6518             contr(j,iii)=expfac
6519           enddo ! j
6520
6521         enddo ! iii
6522
6523         x(3)=x3
6524 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6525 ! subsequent NaNs and INFs in energy calculation.
6526 ! Find the largest exponent
6527         emin=contr(1,-1)
6528         do iii=-1,1
6529           do j=1,nlobit
6530             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6531           enddo
6532         enddo
6533         emin=0.5D0*emin
6534 !d      print *,'it=',it,' emin=',emin
6535
6536 ! Compute the contribution to SC energy and derivatives
6537         do iii=-1,1
6538
6539           do j=1,nlobit
6540 #ifdef OSF
6541             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6542             if(adexp.ne.adexp) adexp=1.0
6543             expfac=dexp(adexp)
6544 #else
6545             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6546 #endif
6547 !d          print *,'j=',j,' expfac=',expfac
6548             escloc_i=escloc_i+expfac
6549             do k=1,3
6550               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6551             enddo
6552             if (mixed) then
6553               do k=1,3,2
6554                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6555                   +gaussc(k,2,j,it))*expfac
6556               enddo
6557             endif
6558           enddo
6559
6560         enddo ! iii
6561
6562         dersc(1)=dersc(1)/cos(theti)**2
6563         ddersc(1)=ddersc(1)/cos(theti)**2
6564         ddersc(3)=ddersc(3)
6565
6566         escloci=-(dlog(escloc_i)-emin)
6567         do j=1,3
6568           dersc(j)=dersc(j)/escloc_i
6569         enddo
6570         if (mixed) then
6571           do j=1,3,2
6572             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6573           enddo
6574         endif
6575       return
6576       end subroutine enesc
6577 !-----------------------------------------------------------------------------
6578       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6579
6580       use comm_sccalc
6581 !      implicit real*8 (a-h,o-z)
6582 !      include 'DIMENSIONS'
6583 !      include 'COMMON.GEO'
6584 !      include 'COMMON.LOCAL'
6585 !      include 'COMMON.IOUNITS'
6586 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6587       real(kind=8),dimension(3) :: x,z,dersc
6588       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6589       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6590       real(kind=8) :: escloci,dersc12,emin
6591       logical :: mixed
6592 !el local varables
6593       integer :: j,k,l !el,it,nlobit
6594       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6595
6596       escloc_i=0.0D0
6597
6598       do j=1,3
6599         dersc(j)=0.0D0
6600       enddo
6601
6602       do j=1,nlobit
6603         do k=1,2
6604           z(k)=x(k)-censc(k,j,it)
6605         enddo
6606         z(3)=dwapi
6607         do k=1,3
6608           Axk=0.0D0
6609           do l=1,3
6610             Axk=Axk+gaussc(l,k,j,it)*z(l)
6611           enddo
6612           Ax(k,j)=Axk
6613         enddo
6614         expfac=0.0D0
6615         do k=1,3
6616           expfac=expfac+Ax(k,j)*z(k)
6617         enddo
6618         contr(j)=expfac
6619       enddo ! j
6620
6621 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6622 ! subsequent NaNs and INFs in energy calculation.
6623 ! Find the largest exponent
6624       emin=contr(1)
6625       do j=1,nlobit
6626         if (emin.gt.contr(j)) emin=contr(j)
6627       enddo
6628       emin=0.5D0*emin
6629
6630 ! Compute the contribution to SC energy and derivatives
6631
6632       dersc12=0.0d0
6633       do j=1,nlobit
6634         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6635         escloc_i=escloc_i+expfac
6636         do k=1,2
6637           dersc(k)=dersc(k)+Ax(k,j)*expfac
6638         enddo
6639         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6640                   +gaussc(1,2,j,it))*expfac
6641         dersc(3)=0.0d0
6642       enddo
6643
6644       dersc(1)=dersc(1)/cos(theti)**2
6645       dersc12=dersc12/cos(theti)**2
6646       escloci=-(dlog(escloc_i)-emin)
6647       do j=1,2
6648         dersc(j)=dersc(j)/escloc_i
6649       enddo
6650       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6651       return
6652       end subroutine enesc_bound
6653 #else
6654 !-----------------------------------------------------------------------------
6655       subroutine esc(escloc)
6656 ! Calculate the local energy of a side chain and its derivatives in the
6657 ! corresponding virtual-bond valence angles THETA and the spherical angles
6658 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6659 ! added by Urszula Kozlowska. 07/11/2007
6660 !
6661       use comm_sccalc
6662 !      implicit real*8 (a-h,o-z)
6663 !      include 'DIMENSIONS'
6664 !      include 'COMMON.GEO'
6665 !      include 'COMMON.LOCAL'
6666 !      include 'COMMON.VAR'
6667 !      include 'COMMON.SCROT'
6668 !      include 'COMMON.INTERACT'
6669 !      include 'COMMON.DERIV'
6670 !      include 'COMMON.CHAIN'
6671 !      include 'COMMON.IOUNITS'
6672 !      include 'COMMON.NAMES'
6673 !      include 'COMMON.FFIELD'
6674 !      include 'COMMON.CONTROL'
6675 !      include 'COMMON.VECTORS'
6676       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6677       real(kind=8),dimension(65) :: x
6678       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6679          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6680       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6681       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6682          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6683 !el local variables
6684       integer :: i,j,k !el,it,nlobit
6685       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6686 !el      real(kind=8) :: time11,time12,time112,theti
6687 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6688       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6689                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6690                    sumene1x,sumene2x,sumene3x,sumene4x,&
6691                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6692                    cosfac2xx,sinfac2yy
6693 #ifdef DEBUG
6694       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6695                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6696                    de_dt_num
6697 #endif
6698 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6699
6700       delta=0.02d0*pi
6701       escloc=0.0D0
6702       do i=loc_start,loc_end
6703         if (itype(i,1).eq.ntyp1) cycle
6704         costtab(i+1) =dcos(theta(i+1))
6705         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6706         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6707         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6708         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6709         cosfac=dsqrt(cosfac2)
6710         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6711         sinfac=dsqrt(sinfac2)
6712         it=iabs(itype(i,1))
6713         if (it.eq.10) goto 1
6714 !
6715 !  Compute the axes of tghe local cartesian coordinates system; store in
6716 !   x_prime, y_prime and z_prime
6717 !
6718         do j=1,3
6719           x_prime(j) = 0.00
6720           y_prime(j) = 0.00
6721           z_prime(j) = 0.00
6722         enddo
6723 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6724 !     &   dc_norm(3,i+nres)
6725         do j = 1,3
6726           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6727           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6728         enddo
6729         do j = 1,3
6730           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6731         enddo
6732 !       write (2,*) "i",i
6733 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6734 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6735 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6736 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6737 !      & " xy",scalar(x_prime(1),y_prime(1)),
6738 !      & " xz",scalar(x_prime(1),z_prime(1)),
6739 !      & " yy",scalar(y_prime(1),y_prime(1)),
6740 !      & " yz",scalar(y_prime(1),z_prime(1)),
6741 !      & " zz",scalar(z_prime(1),z_prime(1))
6742 !
6743 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6744 ! to local coordinate system. Store in xx, yy, zz.
6745 !
6746         xx=0.0d0
6747         yy=0.0d0
6748         zz=0.0d0
6749         do j = 1,3
6750           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6751           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6752           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6753         enddo
6754
6755         xxtab(i)=xx
6756         yytab(i)=yy
6757         zztab(i)=zz
6758 !
6759 ! Compute the energy of the ith side cbain
6760 !
6761 !        write (2,*) "xx",xx," yy",yy," zz",zz
6762         it=iabs(itype(i,1))
6763         do j = 1,65
6764           x(j) = sc_parmin(j,it)
6765         enddo
6766 #ifdef CHECK_COORD
6767 !c diagnostics - remove later
6768         xx1 = dcos(alph(2))
6769         yy1 = dsin(alph(2))*dcos(omeg(2))
6770         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6771         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6772           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6773           xx1,yy1,zz1
6774 !,"  --- ", xx_w,yy_w,zz_w
6775 ! end diagnostics
6776 #endif
6777         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6778          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6779          + x(10)*yy*zz
6780         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6781          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6782          + x(20)*yy*zz
6783         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6784          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6785          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6786          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6787          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6788          +x(40)*xx*yy*zz
6789         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6790          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6791          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6792          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6793          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6794          +x(60)*xx*yy*zz
6795         dsc_i   = 0.743d0+x(61)
6796         dp2_i   = 1.9d0+x(62)
6797         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6798                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6799         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6800                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6801         s1=(1+x(63))/(0.1d0 + dscp1)
6802         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6803         s2=(1+x(65))/(0.1d0 + dscp2)
6804         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6805         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6806       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6807 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6808 !     &   sumene4,
6809 !     &   dscp1,dscp2,sumene
6810 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6811         escloc = escloc + sumene
6812        if (energy_dec) write (2,*) "i",i," itype",itype(i,1)," it",it, &
6813         " escloc",sumene,escloc,it,itype(i,1)
6814 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6815 !     & ,zz,xx,yy
6816 !#define DEBUG
6817 #ifdef DEBUG
6818 !
6819 ! This section to check the numerical derivatives of the energy of ith side
6820 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6821 ! #define DEBUG in the code to turn it on.
6822 !
6823         write (2,*) "sumene               =",sumene
6824         aincr=1.0d-7
6825         xxsave=xx
6826         xx=xx+aincr
6827         write (2,*) xx,yy,zz
6828         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6829         de_dxx_num=(sumenep-sumene)/aincr
6830         xx=xxsave
6831         write (2,*) "xx+ sumene from enesc=",sumenep
6832         yysave=yy
6833         yy=yy+aincr
6834         write (2,*) xx,yy,zz
6835         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6836         de_dyy_num=(sumenep-sumene)/aincr
6837         yy=yysave
6838         write (2,*) "yy+ sumene from enesc=",sumenep
6839         zzsave=zz
6840         zz=zz+aincr
6841         write (2,*) xx,yy,zz
6842         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6843         de_dzz_num=(sumenep-sumene)/aincr
6844         zz=zzsave
6845         write (2,*) "zz+ sumene from enesc=",sumenep
6846         costsave=cost2tab(i+1)
6847         sintsave=sint2tab(i+1)
6848         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6849         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6850         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6851         de_dt_num=(sumenep-sumene)/aincr
6852         write (2,*) " t+ sumene from enesc=",sumenep
6853         cost2tab(i+1)=costsave
6854         sint2tab(i+1)=sintsave
6855 ! End of diagnostics section.
6856 #endif
6857 !
6858 ! Compute the gradient of esc
6859 !
6860 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6861         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6862         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6863         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6864         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6865         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6866         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6867         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6868         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6869         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6870            *(pom_s1/dscp1+pom_s16*dscp1**4)
6871         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6872            *(pom_s2/dscp2+pom_s26*dscp2**4)
6873         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6874         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6875         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6876         +x(40)*yy*zz
6877         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6878         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6879         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6880         +x(60)*yy*zz
6881         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6882               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6883               +(pom1+pom2)*pom_dx
6884 #ifdef DEBUG
6885         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6886 #endif
6887 !
6888         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6889         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6890         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6891         +x(40)*xx*zz
6892         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6893         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6894         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6895         +x(59)*zz**2 +x(60)*xx*zz
6896         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6897               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6898               +(pom1-pom2)*pom_dy
6899 #ifdef DEBUG
6900         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6901 #endif
6902 !
6903         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6904         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6905         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6906         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6907         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6908         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6909         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6910         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6911 #ifdef DEBUG
6912         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6913 #endif
6914 !
6915         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6916         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6917         +pom1*pom_dt1+pom2*pom_dt2
6918 #ifdef DEBUG
6919         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6920 #endif
6921 !
6922 !
6923        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6924        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6925        cosfac2xx=cosfac2*xx
6926        sinfac2yy=sinfac2*yy
6927        do k = 1,3
6928          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6929             vbld_inv(i+1)
6930          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6931             vbld_inv(i)
6932          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6933          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6934 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6935 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6936 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6937 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6938          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6939          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6940          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6941          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6942          dZZ_Ci1(k)=0.0d0
6943          dZZ_Ci(k)=0.0d0
6944          do j=1,3
6945            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6946            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6947            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6948            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6949          enddo
6950
6951          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6952          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6953          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6954          (z_prime(k)-zz*dC_norm(k,i+nres))
6955 !
6956          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6957          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6958        enddo
6959
6960        do k=1,3
6961          dXX_Ctab(k,i)=dXX_Ci(k)
6962          dXX_C1tab(k,i)=dXX_Ci1(k)
6963          dYY_Ctab(k,i)=dYY_Ci(k)
6964          dYY_C1tab(k,i)=dYY_Ci1(k)
6965          dZZ_Ctab(k,i)=dZZ_Ci(k)
6966          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6967          dXX_XYZtab(k,i)=dXX_XYZ(k)
6968          dYY_XYZtab(k,i)=dYY_XYZ(k)
6969          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6970        enddo
6971
6972        do k = 1,3
6973 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6974 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6975 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6976 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6977 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6978 !     &    dt_dci(k)
6979 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6980 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6981          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6982           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6983          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6984           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6985          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6986           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6987        enddo
6988 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6989 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6990
6991 ! to check gradient call subroutine check_grad
6992
6993     1 continue
6994       enddo
6995       return
6996       end subroutine esc
6997 !-----------------------------------------------------------------------------
6998       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6999 !      implicit none
7000       real(kind=8),dimension(65) :: x
7001       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
7002         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7003
7004       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
7005         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
7006         + x(10)*yy*zz
7007       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
7008         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
7009         + x(20)*yy*zz
7010       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
7011         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
7012         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
7013         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
7014         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
7015         +x(40)*xx*yy*zz
7016       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
7017         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
7018         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
7019         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
7020         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
7021         +x(60)*xx*yy*zz
7022       dsc_i   = 0.743d0+x(61)
7023       dp2_i   = 1.9d0+x(62)
7024       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7025                 *(xx*cost2+yy*sint2))
7026       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
7027                 *(xx*cost2-yy*sint2))
7028       s1=(1+x(63))/(0.1d0 + dscp1)
7029       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7030       s2=(1+x(65))/(0.1d0 + dscp2)
7031       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7032       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
7033        + (sumene4*cost2 +sumene2)*(s2+s2_6)
7034       enesc=sumene
7035       return
7036       end function enesc
7037 #endif
7038 !-----------------------------------------------------------------------------
7039       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7040 !
7041 ! This procedure calculates two-body contact function g(rij) and its derivative:
7042 !
7043 !           eps0ij                                     !       x < -1
7044 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7045 !            0                                         !       x > 1
7046 !
7047 ! where x=(rij-r0ij)/delta
7048 !
7049 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7050 !
7051 !      implicit none
7052       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
7053       real(kind=8) :: x,x2,x4,delta
7054 !     delta=0.02D0*r0ij
7055 !      delta=0.2D0*r0ij
7056       x=(rij-r0ij)/delta
7057       if (x.lt.-1.0D0) then
7058         fcont=eps0ij
7059         fprimcont=0.0D0
7060       else if (x.le.1.0D0) then
7061         x2=x*x
7062         x4=x2*x2
7063         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7064         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7065       else
7066         fcont=0.0D0
7067         fprimcont=0.0D0
7068       endif
7069       return
7070       end subroutine gcont
7071 !-----------------------------------------------------------------------------
7072       subroutine splinthet(theti,delta,ss,ssder)
7073 !      implicit real*8 (a-h,o-z)
7074 !      include 'DIMENSIONS'
7075 !      include 'COMMON.VAR'
7076 !      include 'COMMON.GEO'
7077       real(kind=8) :: theti,delta,ss,ssder
7078       real(kind=8) :: thetup,thetlow
7079       thetup=pi-delta
7080       thetlow=delta
7081       if (theti.gt.pipol) then
7082         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7083       else
7084         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7085         ssder=-ssder
7086       endif
7087       return
7088       end subroutine splinthet
7089 !-----------------------------------------------------------------------------
7090       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7091 !      implicit none
7092       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
7093       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7094       a1=fprim0*delta/(f1-f0)
7095       a2=3.0d0-2.0d0*a1
7096       a3=a1-2.0d0
7097       ksi=(x-x0)/delta
7098       ksi2=ksi*ksi
7099       ksi3=ksi2*ksi
7100       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7101       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7102       return
7103       end subroutine spline1
7104 !-----------------------------------------------------------------------------
7105       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7106 !      implicit none
7107       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
7108       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
7109       ksi=(x-x0)/delta
7110       ksi2=ksi*ksi
7111       ksi3=ksi2*ksi
7112       a1=fprim0x*delta
7113       a2=3*(f1x-f0x)-2*fprim0x*delta
7114       a3=fprim0x*delta-2*(f1x-f0x)
7115       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7116       return
7117       end subroutine spline2
7118 !-----------------------------------------------------------------------------
7119 #ifdef CRYST_TOR
7120 !-----------------------------------------------------------------------------
7121       subroutine etor(etors,edihcnstr)
7122 !      implicit real*8 (a-h,o-z)
7123 !      include 'DIMENSIONS'
7124 !      include 'COMMON.VAR'
7125 !      include 'COMMON.GEO'
7126 !      include 'COMMON.LOCAL'
7127 !      include 'COMMON.TORSION'
7128 !      include 'COMMON.INTERACT'
7129 !      include 'COMMON.DERIV'
7130 !      include 'COMMON.CHAIN'
7131 !      include 'COMMON.NAMES'
7132 !      include 'COMMON.IOUNITS'
7133 !      include 'COMMON.FFIELD'
7134 !      include 'COMMON.TORCNSTR'
7135 !      include 'COMMON.CONTROL'
7136       real(kind=8) :: etors,edihcnstr
7137       logical :: lprn
7138 !el local variables
7139       integer :: i,j,
7140       real(kind=8) :: phii,fac,etors_ii
7141
7142 ! Set lprn=.true. for debugging
7143       lprn=.false.
7144 !      lprn=.true.
7145       etors=0.0D0
7146       do i=iphi_start,iphi_end
7147       etors_ii=0.0D0
7148         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7149             .or. itype(i,1).eq.ntyp1) cycle
7150         itori=itortyp(itype(i-2,1))
7151         itori1=itortyp(itype(i-1,1))
7152         phii=phi(i)
7153         gloci=0.0D0
7154 ! Proline-Proline pair is a special case...
7155         if (itori.eq.3 .and. itori1.eq.3) then
7156           if (phii.gt.-dwapi3) then
7157             cosphi=dcos(3*phii)
7158             fac=1.0D0/(1.0D0-cosphi)
7159             etorsi=v1(1,3,3)*fac
7160             etorsi=etorsi+etorsi
7161             etors=etors+etorsi-v1(1,3,3)
7162             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7163             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7164           endif
7165           do j=1,3
7166             v1ij=v1(j+1,itori,itori1)
7167             v2ij=v2(j+1,itori,itori1)
7168             cosphi=dcos(j*phii)
7169             sinphi=dsin(j*phii)
7170             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7171             if (energy_dec) etors_ii=etors_ii+ &
7172                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7173             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7174           enddo
7175         else
7176           do j=1,nterm_old
7177             v1ij=v1(j,itori,itori1)
7178             v2ij=v2(j,itori,itori1)
7179             cosphi=dcos(j*phii)
7180             sinphi=dsin(j*phii)
7181             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7182             if (energy_dec) etors_ii=etors_ii+ &
7183                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7184             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7185           enddo
7186         endif
7187         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7188              'etor',i,etors_ii
7189         if (lprn) &
7190         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7191         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7192         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7193         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7194 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7195       enddo
7196 ! 6/20/98 - dihedral angle constraints
7197       edihcnstr=0.0d0
7198       do i=1,ndih_constr
7199         itori=idih_constr(i)
7200         phii=phi(itori)
7201         difi=phii-phi0(i)
7202         if (difi.gt.drange(i)) then
7203           difi=difi-drange(i)
7204           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7205           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7206         else if (difi.lt.-drange(i)) then
7207           difi=difi+drange(i)
7208           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7209           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7210         endif
7211 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7212 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7213       enddo
7214 !      write (iout,*) 'edihcnstr',edihcnstr
7215       return
7216       end subroutine etor
7217 !-----------------------------------------------------------------------------
7218       subroutine etor_d(etors_d)
7219       real(kind=8) :: etors_d
7220       etors_d=0.0d0
7221       return
7222       end subroutine etor_d
7223 !-----------------------------------------------------------------------------
7224 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
7225       subroutine e_modeller(ehomology_constr)
7226       real(kind=8) :: ehomology_constr
7227       ehomology_constr=0.0d0
7228       write (iout,*) "!!!!!UWAGA, JESTEM W DZIWNEJ PETLI, TEST!!!!!"
7229       return
7230       end subroutine e_modeller
7231 C !!!!!!!! NIE CZYTANE !!!!!!!!!!!
7232 #else
7233 !-----------------------------------------------------------------------------
7234       subroutine etor(etors)
7235 !      implicit real*8 (a-h,o-z)
7236 !      include 'DIMENSIONS'
7237 !      include 'COMMON.VAR'
7238 !      include 'COMMON.GEO'
7239 !      include 'COMMON.LOCAL'
7240 !      include 'COMMON.TORSION'
7241 !      include 'COMMON.INTERACT'
7242 !      include 'COMMON.DERIV'
7243 !      include 'COMMON.CHAIN'
7244 !      include 'COMMON.NAMES'
7245 !      include 'COMMON.IOUNITS'
7246 !      include 'COMMON.FFIELD'
7247 !      include 'COMMON.TORCNSTR'
7248 !      include 'COMMON.CONTROL'
7249       real(kind=8) :: etors,edihcnstr
7250       logical :: lprn
7251 !el local variables
7252       integer :: i,j,iblock,itori,itori1
7253       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7254                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
7255 ! Set lprn=.true. for debugging
7256       lprn=.false.
7257 !     lprn=.true.
7258       etors=0.0D0
7259       do i=iphi_start,iphi_end
7260         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7261              .or. itype(i-3,1).eq.ntyp1 &
7262              .or. itype(i,1).eq.ntyp1) cycle
7263         etors_ii=0.0D0
7264          if (iabs(itype(i,1)).eq.20) then
7265          iblock=2
7266          else
7267          iblock=1
7268          endif
7269         itori=itortyp(itype(i-2,1))
7270         itori1=itortyp(itype(i-1,1))
7271         phii=phi(i)
7272         gloci=0.0D0
7273 ! Regular cosine and sine terms
7274         do j=1,nterm(itori,itori1,iblock)
7275           v1ij=v1(j,itori,itori1,iblock)
7276           v2ij=v2(j,itori,itori1,iblock)
7277           cosphi=dcos(j*phii)
7278           sinphi=dsin(j*phii)
7279           etors=etors+v1ij*cosphi+v2ij*sinphi
7280           if (energy_dec) etors_ii=etors_ii+ &
7281                      v1ij*cosphi+v2ij*sinphi
7282           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7283         enddo
7284 ! Lorentz terms
7285 !                         v1
7286 !  E = SUM ----------------------------------- - v1
7287 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7288 !
7289         cosphi=dcos(0.5d0*phii)
7290         sinphi=dsin(0.5d0*phii)
7291         do j=1,nlor(itori,itori1,iblock)
7292           vl1ij=vlor1(j,itori,itori1)
7293           vl2ij=vlor2(j,itori,itori1)
7294           vl3ij=vlor3(j,itori,itori1)
7295           pom=vl2ij*cosphi+vl3ij*sinphi
7296           pom1=1.0d0/(pom*pom+1.0d0)
7297           etors=etors+vl1ij*pom1
7298           if (energy_dec) etors_ii=etors_ii+ &
7299                      vl1ij*pom1
7300           pom=-pom*pom1*pom1
7301           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7302         enddo
7303 ! Subtract the constant term
7304         etors=etors-v0(itori,itori1,iblock)
7305           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7306                'etor',i,etors_ii-v0(itori,itori1,iblock)
7307         if (lprn) &
7308         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7309         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7310         (v1(j,itori,itori1,iblock),j=1,6),&
7311         (v2(j,itori,itori1,iblock),j=1,6)
7312         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7313 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7314       enddo
7315 ! 6/20/98 - dihedral angle constraints
7316       return
7317       end subroutine etor
7318 !C The rigorous attempt to derive energy function
7319 !-------------------------------------------------------------------------------------------
7320       subroutine etor_kcc(etors)
7321       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7322       real(kind=8) :: etors,glocig,glocit1,glocit2,sinthet1,&
7323        sinthet2,costhet1,costhet2,sint1t2,sint1t2n,phii,sinphi,cosphi,&
7324        sint1t2n1,sumvalc,gradvalct1,gradvalct2,sumvals,gradvalst1,&
7325        gradvalst2,etori
7326       logical lprn
7327       integer :: i,j,itori,itori1,nval,k,l
7328
7329       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7330       etors=0.0D0
7331       do i=iphi_start,iphi_end
7332 !C ANY TWO ARE DUMMY ATOMS in row CYCLE
7333 !c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7334 !c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7335 !c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7336         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
7337            .or. itype(i,1).eq.ntyp1 .or. itype(i-3,1).eq.ntyp1) cycle
7338         itori=itortyp(itype(i-2,1))
7339         itori1=itortyp(itype(i-1,1))
7340         phii=phi(i)
7341         glocig=0.0D0
7342         glocit1=0.0d0
7343         glocit2=0.0d0
7344 !C to avoid multiple devision by 2
7345 !c        theti22=0.5d0*theta(i)
7346 !C theta 12 is the theta_1 /2
7347 !C theta 22 is theta_2 /2
7348 !c        theti12=0.5d0*theta(i-1)
7349 !C and appropriate sinus function
7350         sinthet1=dsin(theta(i-1))
7351         sinthet2=dsin(theta(i))
7352         costhet1=dcos(theta(i-1))
7353         costhet2=dcos(theta(i))
7354 !C to speed up lets store its mutliplication
7355         sint1t2=sinthet2*sinthet1
7356         sint1t2n=1.0d0
7357 !C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7358 !C +d_n*sin(n*gamma)) *
7359 !C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7360 !C we have two sum 1) Non-Chebyshev which is with n and gamma
7361         nval=nterm_kcc_Tb(itori,itori1)
7362         c1(0)=0.0d0
7363         c2(0)=0.0d0
7364         c1(1)=1.0d0
7365         c2(1)=1.0d0
7366         do j=2,nval
7367           c1(j)=c1(j-1)*costhet1
7368           c2(j)=c2(j-1)*costhet2
7369         enddo
7370         etori=0.0d0
7371
7372        do j=1,nterm_kcc(itori,itori1)
7373           cosphi=dcos(j*phii)
7374           sinphi=dsin(j*phii)
7375           sint1t2n1=sint1t2n
7376           sint1t2n=sint1t2n*sint1t2
7377           sumvalc=0.0d0
7378           gradvalct1=0.0d0
7379           gradvalct2=0.0d0
7380           do k=1,nval
7381             do l=1,nval
7382               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7383               gradvalct1=gradvalct1+ &
7384                 (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7385               gradvalct2=gradvalct2+ &
7386                 (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7387             enddo
7388           enddo
7389           gradvalct1=-gradvalct1*sinthet1
7390           gradvalct2=-gradvalct2*sinthet2
7391           sumvals=0.0d0
7392           gradvalst1=0.0d0
7393           gradvalst2=0.0d0
7394           do k=1,nval
7395             do l=1,nval
7396               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7397               gradvalst1=gradvalst1+ &
7398                 (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7399               gradvalst2=gradvalst2+ &
7400                 (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7401             enddo
7402           enddo
7403           gradvalst1=-gradvalst1*sinthet1
7404           gradvalst2=-gradvalst2*sinthet2
7405           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7406           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7407 !C glocig is the gradient local i site in gamma
7408           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7409 !C now gradient over theta_1
7410          glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)&
7411         +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7412          glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)&
7413         +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7414         enddo ! j
7415         etors=etors+etori
7416         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7417 !C derivative over theta1
7418         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7419 !C now derivative over theta2
7420         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7421         if (lprn) then
7422          write (iout,*) i-2,i-1,itype(i-2,1),itype(i-1,1),itori,itori1,&
7423             theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7424           write (iout,*) "c1",(c1(k),k=0,nval), &
7425          " c2",(c2(k),k=0,nval)
7426         endif
7427       enddo
7428       return
7429        end  subroutine etor_kcc
7430 !------------------------------------------------------------------------------
7431
7432         subroutine etor_constr(edihcnstr)
7433       real(kind=8) :: etors,edihcnstr
7434       logical :: lprn
7435 !el local variables
7436       integer :: i,j,iblock,itori,itori1
7437       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7438                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom,&
7439                    gaudih_i,gauder_i,s,cos_i,dexpcos_i
7440
7441       if (raw_psipred) then
7442         do i=idihconstr_start,idihconstr_end
7443           itori=idih_constr(i)
7444           phii=phi(itori)
7445           gaudih_i=vpsipred(1,i)
7446           gauder_i=0.0d0
7447           do j=1,2
7448             s = sdihed(j,i)
7449             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7450             dexpcos_i=dexp(-cos_i*cos_i)
7451             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7452           gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i)) &
7453                  *cos_i*dexpcos_i/s**2
7454           enddo
7455           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7456           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7457           if (energy_dec) &
7458           write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)') &
7459           i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),&
7460           phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),&
7461           phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,&
7462           -wdihc*dlog(gaudih_i)
7463         enddo
7464       else
7465
7466       do i=idihconstr_start,idihconstr_end
7467         itori=idih_constr(i)
7468         phii=phi(itori)
7469         difi=pinorm(phii-phi0(i))
7470         if (difi.gt.drange(i)) then
7471           difi=difi-drange(i)
7472           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7473           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7474         else if (difi.lt.-drange(i)) then
7475           difi=difi+drange(i)
7476           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7477           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7478         else
7479           difi=0.0
7480         endif
7481       enddo
7482
7483       endif
7484
7485       return
7486
7487       end subroutine etor_constr
7488 !-----------------------------------------------------------------------------
7489       subroutine etor_d(etors_d)
7490 ! 6/23/01 Compute double torsional energy
7491 !      implicit real*8 (a-h,o-z)
7492 !      include 'DIMENSIONS'
7493 !      include 'COMMON.VAR'
7494 !      include 'COMMON.GEO'
7495 !      include 'COMMON.LOCAL'
7496 !      include 'COMMON.TORSION'
7497 !      include 'COMMON.INTERACT'
7498 !      include 'COMMON.DERIV'
7499 !      include 'COMMON.CHAIN'
7500 !      include 'COMMON.NAMES'
7501 !      include 'COMMON.IOUNITS'
7502 !      include 'COMMON.FFIELD'
7503 !      include 'COMMON.TORCNSTR'
7504       real(kind=8) :: etors_d,etors_d_ii
7505       logical :: lprn
7506 !el local variables
7507       integer :: i,j,k,l,itori,itori1,itori2,iblock
7508       real(kind=8) :: phii,phii1,gloci1,gloci2,&
7509                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
7510                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
7511                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
7512 ! Set lprn=.true. for debugging
7513       lprn=.false.
7514 !     lprn=.true.
7515       etors_d=0.0D0
7516 !      write(iout,*) "a tu??"
7517       do i=iphid_start,iphid_end
7518         etors_d_ii=0.0D0
7519         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7520             .or. itype(i-3,1).eq.ntyp1 &
7521             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
7522         itori=itortyp(itype(i-2,1))
7523         itori1=itortyp(itype(i-1,1))
7524         itori2=itortyp(itype(i,1))
7525         phii=phi(i)
7526         phii1=phi(i+1)
7527         gloci1=0.0D0
7528         gloci2=0.0D0
7529         iblock=1
7530         if (iabs(itype(i+1,1)).eq.20) iblock=2
7531
7532 ! Regular cosine and sine terms
7533         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7534           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7535           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7536           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7537           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7538           cosphi1=dcos(j*phii)
7539           sinphi1=dsin(j*phii)
7540           cosphi2=dcos(j*phii1)
7541           sinphi2=dsin(j*phii1)
7542           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
7543            v2cij*cosphi2+v2sij*sinphi2
7544           if (energy_dec) etors_d_ii=etors_d_ii+ &
7545            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7546           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7547           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7548         enddo
7549         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7550           do l=1,k-1
7551             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7552             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7553             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7554             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7555             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7556             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7557             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7558             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7559             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7560               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7561             if (energy_dec) etors_d_ii=etors_d_ii+ &
7562               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7563               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7564             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7565               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7566             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7567               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7568           enddo
7569         enddo
7570         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7571                             'etor_d',i,etors_d_ii
7572         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7573         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7574       enddo
7575       return
7576       end subroutine etor_d
7577 #endif
7578 !----------------------------------------------------------------------------
7579 !----------------------------------------------------------------------------
7580       subroutine e_modeller(ehomology_constr)
7581 !      implicit none
7582 !      include 'DIMENSIONS'
7583       use MD_data, only: iset
7584       real(kind=8) :: ehomology_constr
7585       integer nnn,i,ii,j,k,ijk,jik,ki,kk,nexl,irec,l
7586       integer katy, odleglosci, test7
7587       real(kind=8) :: odleg, odleg2, odleg3, kat, kat2, kat3
7588       real(kind=8) :: Eval,Erot,min_odl
7589       real(kind=8),dimension(constr_homology) :: distance,distancek,godl,dih_diff,gdih, &
7590       gtheta,dscdiff, &
7591                 uscdiffk,guscdiff2,guscdiff3,&
7592                 theta_diff
7593
7594
7595 !
7596 !     FP - 30/10/2014 Temporary specifications for homology restraints
7597 !
7598       real(kind=8) :: utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,&
7599                       sgtheta
7600       real(kind=8), dimension (nres) :: guscdiff,usc_diff
7601       real(kind=8) :: sum_godl,sgodl,grad_odl3,ggodl,sum_gdih,&
7602       sum_guscdiff,sum_sgdih,sgdih,grad_dih3,usc_diff_i,dxx,dyy,dzz,&
7603       betai,sum_sgodl,dij,max_template
7604 !      real(kind=8) :: dist,pinorm
7605 !
7606 !     include 'COMMON.SBRIDGE'
7607 !     include 'COMMON.CHAIN'
7608 !     include 'COMMON.GEO'
7609 !     include 'COMMON.DERIV'
7610 !     include 'COMMON.LOCAL'
7611 !     include 'COMMON.INTERACT'
7612 !     include 'COMMON.VAR'
7613 !     include 'COMMON.IOUNITS'
7614 !      include 'COMMON.MD'
7615 !     include 'COMMON.CONTROL'
7616 !     include 'COMMON.HOMOLOGY'
7617 !     include 'COMMON.QRESTR'
7618 !
7619 !     From subroutine Econstr_back
7620 !
7621 !     include 'COMMON.NAMES'
7622 !     include 'COMMON.TIME1'
7623 !
7624
7625
7626       do i=1,max_template
7627         distancek(i)=9999999.9
7628       enddo
7629
7630
7631       odleg=0.0d0
7632
7633 ! Pseudo-energy and gradient from homology restraints (MODELLER-like
7634 ! function)
7635 ! AL 5/2/14 - Introduce list of restraints
7636 !     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
7637 #ifdef DEBUG
7638       write(iout,*) "------- dist restrs start -------"
7639 #endif
7640       do ii = link_start_homo,link_end_homo
7641          i = ires_homo(ii)
7642          j = jres_homo(ii)
7643          dij=dist(i,j)
7644 !        write (iout,*) "dij(",i,j,") =",dij
7645          nexl=0
7646          do k=1,constr_homology
7647 !           write(iout,*) ii,k,i,j,l_homo(k,ii),dij,odl(k,ii)
7648            if(.not.l_homo(k,ii)) then
7649              nexl=nexl+1
7650              cycle
7651            endif
7652            distance(k)=odl(k,ii)-dij
7653 !          write (iout,*) "distance(",k,") =",distance(k)
7654 !
7655 !          For Gaussian-type Urestr
7656 !
7657            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
7658 !          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
7659 !          write (iout,*) "distancek(",k,") =",distancek(k)
7660 !          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
7661 !
7662 !          For Lorentzian-type Urestr
7663 !
7664            if (waga_dist.lt.0.0d0) then
7665               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
7666               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)* &
7667                           (distance(k)**2+sigma_odlir(k,ii)**2))
7668            endif
7669          enddo
7670
7671 !         min_odl=minval(distancek)
7672          if (nexl.gt.0) then
7673            min_odl=0.0d0
7674          else
7675            do kk=1,constr_homology
7676             if(l_homo(kk,ii)) then
7677               min_odl=distancek(kk)
7678               exit
7679             endif
7680            enddo
7681            do kk=1,constr_homology
7682             if (l_homo(kk,ii) .and. distancek(kk).lt.min_odl) &
7683                    min_odl=distancek(kk)
7684            enddo
7685          endif
7686
7687 !        write (iout,* )"min_odl",min_odl
7688 #ifdef DEBUG
7689          write (iout,*) "ij dij",i,j,dij
7690          write (iout,*) "distance",(distance(k),k=1,constr_homology)
7691          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
7692          write (iout,* )"min_odl",min_odl
7693 #endif
7694 #ifdef OLDRESTR
7695          odleg2=0.0d0
7696 #else
7697          if (waga_dist.ge.0.0d0) then
7698            odleg2=nexl
7699          else
7700            odleg2=0.0d0
7701          endif
7702 #endif
7703          do k=1,constr_homology
7704 ! Nie wiem po co to liczycie jeszcze raz!
7705 !            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
7706 !     &              (2*(sigma_odl(i,j,k))**2))
7707            if(.not.l_homo(k,ii)) cycle
7708            if (waga_dist.ge.0.0d0) then
7709 !
7710 !          For Gaussian-type Urestr
7711 !
7712             godl(k)=dexp(-distancek(k)+min_odl)
7713             odleg2=odleg2+godl(k)
7714 !
7715 !          For Lorentzian-type Urestr
7716 !
7717            else
7718             odleg2=odleg2+distancek(k)
7719            endif
7720
7721 !cc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
7722 !cc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
7723 !cc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
7724 !cc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
7725
7726          enddo
7727 !        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7728 !        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7729 #ifdef DEBUG
7730          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
7731          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
7732 #endif
7733            if (waga_dist.ge.0.0d0) then
7734 !
7735 !          For Gaussian-type Urestr
7736 !
7737               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
7738 !
7739 !          For Lorentzian-type Urestr
7740 !
7741            else
7742               odleg=odleg+odleg2/constr_homology
7743            endif
7744 !
7745 !        write (iout,*) "odleg",odleg ! sum of -ln-s
7746 ! Gradient
7747 !
7748 !          For Gaussian-type Urestr
7749 !
7750          if (waga_dist.ge.0.0d0) sum_godl=odleg2
7751          sum_sgodl=0.0d0
7752          do k=1,constr_homology
7753 !            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7754 !     &           *waga_dist)+min_odl
7755 !          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
7756 !
7757          if(.not.l_homo(k,ii)) cycle
7758          if (waga_dist.ge.0.0d0) then
7759 !          For Gaussian-type Urestr
7760 !
7761            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
7762 !
7763 !          For Lorentzian-type Urestr
7764 !
7765          else
7766            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+ &
7767                 sigma_odlir(k,ii)**2)**2)
7768          endif
7769            sum_sgodl=sum_sgodl+sgodl
7770
7771 !            sgodl2=sgodl2+sgodl
7772 !      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
7773 !      write(iout,*) "constr_homology=",constr_homology
7774 !      write(iout,*) i, j, k, "TEST K"
7775          enddo
7776 !         print *, "ok",iset
7777          if (waga_dist.ge.0.0d0) then
7778 !
7779 !          For Gaussian-type Urestr
7780 !
7781             grad_odl3=waga_homology(iset)*waga_dist &
7782                      *sum_sgodl/(sum_godl*dij)
7783 !         print *, "ok"
7784 !
7785 !          For Lorentzian-type Urestr
7786 !
7787          else
7788 ! Original grad expr modified by analogy w Gaussian-type Urestr grad
7789 !           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
7790             grad_odl3=-waga_homology(iset)*waga_dist* &
7791                      sum_sgodl/(constr_homology*dij)
7792 !         print *, "ok2"
7793          endif
7794 !
7795 !        grad_odl3=sum_sgodl/(sum_godl*dij)
7796
7797
7798 !      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
7799 !      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
7800 !     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
7801
7802 !cc      write(iout,*) godl, sgodl, grad_odl3
7803
7804 !          grad_odl=grad_odl+grad_odl3
7805
7806          do jik=1,3
7807             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
7808 !cc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
7809 !cc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
7810 !cc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7811             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
7812             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
7813 !cc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
7814 !cc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
7815 !         if (i.eq.25.and.j.eq.27) then
7816 !         write(iout,*) "jik",jik,"i",i,"j",j
7817 !         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
7818 !         write(iout,*) "grad_odl3",grad_odl3
7819 !         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
7820 !         write(iout,*) "ggodl",ggodl
7821 !         write(iout,*) "ghpbc(",jik,i,")",
7822 !     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
7823 !     &                 ghpbc(jik,j)
7824 !         endif
7825          enddo
7826 !cc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
7827 !cc     & dLOG(odleg2),"-odleg=", -odleg
7828
7829       enddo ! ii-loop for dist
7830 #ifdef DEBUG
7831       write(iout,*) "------- dist restrs end -------"
7832 !     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
7833 !    &     waga_d.eq.1.0d0) call sum_gradient
7834 #endif
7835 ! Pseudo-energy and gradient from dihedral-angle restraints from
7836 ! homology templates
7837 !      write (iout,*) "End of distance loop"
7838 !      call flush(iout)
7839       kat=0.0d0
7840 !      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
7841 #ifdef DEBUG
7842       write(iout,*) "------- dih restrs start -------"
7843       do i=idihconstr_start_homo,idihconstr_end_homo
7844         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
7845       enddo
7846 #endif
7847       do i=idihconstr_start_homo,idihconstr_end_homo
7848         kat2=0.0d0
7849 !        betai=beta(i,i+1,i+2,i+3)
7850         betai = phi(i)
7851 !       write (iout,*) "betai =",betai
7852         do k=1,constr_homology
7853           dih_diff(k)=pinorm(dih(k,i)-betai)
7854 !d          write (iout,'(a8,2i4,2f15.8)') "dih_diff",i,k,dih_diff(k)
7855 !d     &                  ,sigma_dih(k,i)
7856 !          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
7857 !     &                                   -(6.28318-dih_diff(i,k))
7858 !          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
7859 !     &                                   6.28318+dih_diff(i,k)
7860 #ifdef OLD_DIHED
7861           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7862 #else
7863           kat3=(dcos(dih_diff(k))-1)*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
7864 #endif
7865 !         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
7866           gdih(k)=dexp(kat3)
7867           kat2=kat2+gdih(k)
7868 !          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
7869 !          write(*,*)""
7870         enddo
7871 !       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
7872 !       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
7873 #ifdef DEBUG
7874         write (iout,*) "i",i," betai",betai," kat2",kat2
7875         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
7876 #endif
7877         if (kat2.le.1.0d-14) cycle
7878         kat=kat-dLOG(kat2/constr_homology)
7879 !       write (iout,*) "kat",kat ! sum of -ln-s
7880
7881 !cc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
7882 !cc     & dLOG(kat2), "-kat=", -kat
7883
7884 ! ----------------------------------------------------------------------
7885 ! Gradient
7886 ! ----------------------------------------------------------------------
7887
7888         sum_gdih=kat2
7889         sum_sgdih=0.0d0
7890         do k=1,constr_homology
7891 #ifdef OLD_DIHED
7892           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
7893 #else
7894           sgdih=-gdih(k)*dsin(dih_diff(k))*sigma_dih(k,i)  ! waga_angle rmvd
7895 #endif
7896 !         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
7897           sum_sgdih=sum_sgdih+sgdih
7898         enddo
7899 !       grad_dih3=sum_sgdih/sum_gdih
7900         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
7901 !         print *, "ok3"
7902
7903 !      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
7904 !cc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
7905 !cc     & gloc(nphi+i-3,icg)
7906         gloc(i-3,icg)=gloc(i-3,icg)+grad_dih3
7907 !        if (i.eq.25) then
7908 !        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
7909 !        endif
7910 !cc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
7911 !cc     & gloc(nphi+i-3,icg)
7912
7913       enddo ! i-loop for dih
7914 #ifdef DEBUG
7915       write(iout,*) "------- dih restrs end -------"
7916 #endif
7917
7918 ! Pseudo-energy and gradient for theta angle restraints from
7919 ! homology templates
7920 ! FP 01/15 - inserted from econstr_local_test.F, loop structure
7921 ! adapted
7922
7923 !
7924 !     For constr_homology reference structures (FP)
7925 !
7926 !     Uconst_back_tot=0.0d0
7927       Eval=0.0d0
7928       Erot=0.0d0
7929 !     Econstr_back legacy
7930       do i=1,nres
7931 !     do i=ithet_start,ithet_end
7932        dutheta(i)=0.0d0
7933       enddo
7934 !     do i=loc_start,loc_end
7935       do i=-1,nres
7936         do j=1,3
7937           duscdiff(j,i)=0.0d0
7938           duscdiffx(j,i)=0.0d0
7939         enddo
7940       enddo
7941 !
7942 !     do iref=1,nref
7943 !     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
7944 !     write (iout,*) "waga_theta",waga_theta
7945       if (waga_theta.gt.0.0d0) then
7946 #ifdef DEBUG
7947       write (iout,*) "usampl",usampl
7948       write(iout,*) "------- theta restrs start -------"
7949 !     do i=ithet_start,ithet_end
7950 !       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
7951 !     enddo
7952 #endif
7953 !     write (iout,*) "maxres",maxres,"nres",nres
7954
7955       do i=ithet_start,ithet_end
7956 !
7957 !     do i=1,nfrag_back
7958 !       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
7959 !
7960 ! Deviation of theta angles wrt constr_homology ref structures
7961 !
7962         utheta_i=0.0d0 ! argument of Gaussian for single k
7963         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
7964 !       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
7965 !       over residues in a fragment
7966 !       write (iout,*) "theta(",i,")=",theta(i)
7967         do k=1,constr_homology
7968 !
7969 !         dtheta_i=theta(j)-thetaref(j,iref)
7970 !         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
7971           theta_diff(k)=thetatpl(k,i)-theta(i)
7972 !d          write (iout,'(a8,2i4,2f15.8)') "theta_diff",i,k,theta_diff(k)
7973 !d     &                  ,sigma_theta(k,i)
7974
7975 !
7976           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
7977 !         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
7978           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
7979           gutheta_i=gutheta_i+gtheta(k)  ! Sum of Gaussians (pk)
7980 !         Gradient for single Gaussian restraint in subr Econstr_back
7981 !         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
7982 !
7983         enddo
7984 !       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
7985 !       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
7986
7987 !
7988 !         Gradient for multiple Gaussian restraint
7989         sum_gtheta=gutheta_i
7990         sum_sgtheta=0.0d0
7991         do k=1,constr_homology
7992 !        New generalized expr for multiple Gaussian from Econstr_back
7993          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
7994 !
7995 !        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
7996           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
7997         enddo
7998 !       Final value of gradient using same var as in Econstr_back
7999         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg) &
8000            +sum_sgtheta/sum_gtheta*waga_theta &
8001                     *waga_homology(iset)
8002 !         print *, "ok4"
8003
8004 !        dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
8005 !     &               *waga_homology(iset)
8006 !       dutheta(i)=sum_sgtheta/sum_gtheta
8007 !
8008 !       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
8009         Eval=Eval-dLOG(gutheta_i/constr_homology)
8010 !       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
8011 !       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
8012 !       Uconst_back=Uconst_back+utheta(i)
8013       enddo ! (i-loop for theta)
8014 #ifdef DEBUG
8015       write(iout,*) "------- theta restrs end -------"
8016 #endif
8017       endif
8018 !
8019 ! Deviation of local SC geometry
8020 !
8021 ! Separation of two i-loops (instructed by AL - 11/3/2014)
8022 !
8023 !     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
8024 !     write (iout,*) "waga_d",waga_d
8025
8026 #ifdef DEBUG
8027       write(iout,*) "------- SC restrs start -------"
8028       write (iout,*) "Initial duscdiff,duscdiffx"
8029       do i=loc_start,loc_end
8030         write (iout,*) i,(duscdiff(jik,i),jik=1,3), &
8031                       (duscdiffx(jik,i),jik=1,3)
8032       enddo
8033 #endif
8034       do i=loc_start,loc_end
8035         usc_diff_i=0.0d0 ! argument of Gaussian for single k
8036         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
8037 !       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
8038 !       write(iout,*) "xxtab, yytab, zztab"
8039 !       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
8040         do k=1,constr_homology
8041 !
8042           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8043 !                                    Original sign inverted for calc of gradients (s. Econstr_back)
8044           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8045           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8046 !         write(iout,*) "dxx, dyy, dzz"
8047 !d          write(iout,'(2i5,4f8.2)') k,i,dxx,dyy,dzz,sigma_d(k,i)
8048 !
8049           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
8050 !         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
8051 !         uscdiffk(k)=usc_diff(i)
8052           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
8053 !          write(iout,*) "i",i," k",k," sigma_d",sigma_d(k,i),
8054 !     &       " guscdiff2",guscdiff2(k)
8055           guscdiff(i)=guscdiff(i)+guscdiff2(k)  !Sum of Gaussians (pk)
8056 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
8057 !     &      xxref(j),yyref(j),zzref(j)
8058         enddo
8059 !
8060 !       Gradient
8061 !
8062 !       Generalized expression for multiple Gaussian acc to that for a single
8063 !       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
8064 !
8065 !       Original implementation
8066 !       sum_guscdiff=guscdiff(i)
8067 !
8068 !       sum_sguscdiff=0.0d0
8069 !       do k=1,constr_homology
8070 !          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
8071 !          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
8072 !          sum_sguscdiff=sum_sguscdiff+sguscdiff
8073 !       enddo
8074 !
8075 !       Implementation of new expressions for gradient (Jan. 2015)
8076 !
8077 !       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
8078         do k=1,constr_homology
8079 !
8080 !       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
8081 !       before. Now the drivatives should be correct
8082 !
8083           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
8084 !                                  Original sign inverted for calc of gradients (s. Econstr_back)
8085           dyy=-yytpl(k,i)+yytab(i) ! ibid y
8086           dzz=-zztpl(k,i)+zztab(i) ! ibid z
8087           sum_guscdiff=guscdiff2(k)* &!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
8088                       sigma_d(k,i) ! for the grad wrt r'
8089 !         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
8090
8091 !
8092 !         New implementation
8093          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
8094          do jik=1,3
8095             duscdiff(jik,i-1)=duscdiff(jik,i-1)+ &
8096             sum_guscdiff*(dXX_C1tab(jik,i)*dxx+ &
8097             dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
8098             duscdiff(jik,i)=duscdiff(jik,i)+ &
8099             sum_guscdiff*(dXX_Ctab(jik,i)*dxx+ &
8100             dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
8101             duscdiffx(jik,i)=duscdiffx(jik,i)+ &
8102             sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+ &
8103             dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
8104 !         print *, "ok5"
8105 !
8106 #ifdef DEBUG
8107 !             write(iout,*) "jik",jik,"i",i
8108              write(iout,*) "dxx, dyy, dzz"
8109              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
8110              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
8111             write(iout,*) "sum_sguscdiff",sum_guscdiff,waga_homology(iset),waga_d
8112             write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
8113             write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
8114              write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
8115              write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
8116              write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
8117              write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
8118              write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
8119              write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
8120              write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
8121              write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
8122             write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
8123             write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
8124 !            endif
8125 #endif
8126          enddo
8127         enddo
8128 !         print *, "ok6"
8129 !
8130 !       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
8131 !        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
8132 !
8133 !        write (iout,*) i," uscdiff",uscdiff(i)
8134 !
8135 ! Put together deviations from local geometry
8136
8137 !       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
8138 !      &            wfrag_back(3,i,iset)*uscdiff(i)
8139         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
8140 !       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
8141 !       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
8142 !       Uconst_back=Uconst_back+usc_diff(i)
8143 !
8144 !     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
8145 !
8146 !     New implment: multiplied by sum_sguscdiff
8147 !
8148
8149       enddo ! (i-loop for dscdiff)
8150
8151 !      endif
8152
8153 #ifdef DEBUG
8154       write(iout,*) "------- SC restrs end -------"
8155         write (iout,*) "------ After SC loop in e_modeller ------"
8156         do i=loc_start,loc_end
8157          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
8158          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
8159         enddo
8160       if (waga_theta.eq.1.0d0) then
8161       write (iout,*) "in e_modeller after SC restr end: dutheta"
8162       do i=ithet_start,ithet_end
8163         write (iout,*) i,dutheta(i)
8164       enddo
8165       endif
8166       if (waga_d.eq.1.0d0) then
8167       write (iout,*) "e_modeller after SC loop: duscdiff/x"
8168       do i=1,nres
8169         write (iout,*) i,(duscdiff(j,i),j=1,3)
8170         write (iout,*) i,(duscdiffx(j,i),j=1,3)
8171       enddo
8172       endif
8173 #endif
8174
8175 ! Total energy from homology restraints
8176 #ifdef DEBUG
8177       write (iout,*) "odleg",odleg," kat",kat
8178 #endif
8179 !
8180 ! Addition of energy of theta angle and SC local geom over constr_homologs ref strs
8181 !
8182 !     ehomology_constr=odleg+kat
8183 !
8184 !     For Lorentzian-type Urestr
8185 !
8186
8187       if (waga_dist.ge.0.0d0) then
8188 !
8189 !          For Gaussian-type Urestr
8190 !
8191         ehomology_constr=(waga_dist*odleg+waga_angle*kat+ &
8192                    waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8193 !     write (iout,*) "ehomology_constr=",ehomology_constr
8194 !         print *, "ok7"
8195       else
8196 !
8197 !          For Lorentzian-type Urestr
8198 !
8199         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+ &
8200                    waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
8201 !     write (iout,*) "ehomology_constr=",ehomology_constr
8202          print *, "ok8"
8203       endif
8204 #ifdef DEBUG
8205       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat, &
8206       "Eval",waga_theta,eval, &
8207         "Erot",waga_d,Erot
8208       write (iout,*) "ehomology_constr",ehomology_constr
8209 #endif
8210       return
8211 !
8212 ! FP 01/15 end
8213 !
8214   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
8215   747 format(a12,i4,i4,i4,f8.3,f8.3)
8216   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
8217   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
8218   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X, &
8219             f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
8220       end subroutine e_modeller
8221
8222 !----------------------------------------------------------------------------
8223       subroutine ebend_kcc(etheta)
8224       logical lprn
8225       double precision thybt1(maxang_kcc),etheta
8226       integer :: i,iti,j,ihelp
8227       real (kind=8) :: sinthet,costhet,sumth1thyb,gradthybt1
8228 !C Set lprn=.true. for debugging
8229       lprn=energy_dec
8230 !c     lprn=.true.
8231 !C      print *,"wchodze kcc"
8232       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
8233       etheta=0.0D0
8234       do i=ithet_start,ithet_end
8235 !c        print *,i,itype(i-1),itype(i),itype(i-2)
8236         if ((itype(i-1,1).eq.ntyp1).or.itype(i-2,1).eq.ntyp1 &
8237        .or.itype(i,1).eq.ntyp1) cycle
8238         iti=iabs(itortyp(itype(i-1,1)))
8239         sinthet=dsin(theta(i))
8240         costhet=dcos(theta(i))
8241         do j=1,nbend_kcc_Tb(iti)
8242           thybt1(j)=v1bend_chyb(j,iti)
8243         enddo
8244         sumth1thyb=v1bend_chyb(0,iti)+ &
8245          tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
8246         if (lprn) write (iout,*) i-1,itype(i-1,1),iti,theta(i)*rad2deg,&
8247          sumth1thyb
8248         ihelp=nbend_kcc_Tb(iti)-1
8249         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
8250         etheta=etheta+sumth1thyb
8251 !C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
8252         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
8253       enddo
8254       return
8255       end subroutine ebend_kcc
8256 !c------------
8257 !c-------------------------------------------------------------------------------------
8258       subroutine etheta_constr(ethetacnstr)
8259       real (kind=8) :: ethetacnstr,thetiii,difi
8260       integer :: i,itheta
8261       ethetacnstr=0.0d0
8262 !C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
8263       do i=ithetaconstr_start,ithetaconstr_end
8264         itheta=itheta_constr(i)
8265         thetiii=theta(itheta)
8266         difi=pinorm(thetiii-theta_constr0(i))
8267         if (difi.gt.theta_drange(i)) then
8268           difi=difi-theta_drange(i)
8269           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8270           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
8271          +for_thet_constr(i)*difi**3
8272         else if (difi.lt.-drange(i)) then
8273           difi=difi+drange(i)
8274           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
8275           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
8276           +for_thet_constr(i)*difi**3
8277         else
8278           difi=0.0
8279         endif
8280        if (energy_dec) then
8281         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",&
8282          i,itheta,rad2deg*thetiii,&
8283          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),&
8284          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,&
8285          gloc(itheta+nphi-2,icg)
8286         endif
8287       enddo
8288       return
8289       end subroutine etheta_constr
8290
8291 !-----------------------------------------------------------------------------
8292       subroutine eback_sc_corr(esccor)
8293 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
8294 !        conformational states; temporarily implemented as differences
8295 !        between UNRES torsional potentials (dependent on three types of
8296 !        residues) and the torsional potentials dependent on all 20 types
8297 !        of residues computed from AM1  energy surfaces of terminally-blocked
8298 !        amino-acid residues.
8299 !      implicit real*8 (a-h,o-z)
8300 !      include 'DIMENSIONS'
8301 !      include 'COMMON.VAR'
8302 !      include 'COMMON.GEO'
8303 !      include 'COMMON.LOCAL'
8304 !      include 'COMMON.TORSION'
8305 !      include 'COMMON.SCCOR'
8306 !      include 'COMMON.INTERACT'
8307 !      include 'COMMON.DERIV'
8308 !      include 'COMMON.CHAIN'
8309 !      include 'COMMON.NAMES'
8310 !      include 'COMMON.IOUNITS'
8311 !      include 'COMMON.FFIELD'
8312 !      include 'COMMON.CONTROL'
8313       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
8314                    cosphi,sinphi
8315       logical :: lprn
8316       integer :: i,interty,j,isccori,isccori1,intertyp
8317 ! Set lprn=.true. for debugging
8318       lprn=.false.
8319 !      lprn=.true.
8320 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
8321       esccor=0.0D0
8322       do i=itau_start,itau_end
8323         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
8324         esccor_ii=0.0D0
8325         isccori=isccortyp(itype(i-2,1))
8326         isccori1=isccortyp(itype(i-1,1))
8327
8328 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
8329         phii=phi(i)
8330         do intertyp=1,3 !intertyp
8331          esccor_ii=0.0D0
8332 !c Added 09 May 2012 (Adasko)
8333 !c  Intertyp means interaction type of backbone mainchain correlation:
8334 !   1 = SC...Ca...Ca...Ca
8335 !   2 = Ca...Ca...Ca...SC
8336 !   3 = SC...Ca...Ca...SCi
8337         gloci=0.0D0
8338         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
8339             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
8340             (itype(i-1,1).eq.ntyp1))) &
8341           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
8342            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
8343            .or.(itype(i,1).eq.ntyp1))) &
8344           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
8345             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
8346             (itype(i-3,1).eq.ntyp1)))) cycle
8347         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
8348         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
8349        cycle
8350        do j=1,nterm_sccor(isccori,isccori1)
8351           v1ij=v1sccor(j,intertyp,isccori,isccori1)
8352           v2ij=v2sccor(j,intertyp,isccori,isccori1)
8353           cosphi=dcos(j*tauangle(intertyp,i))
8354           sinphi=dsin(j*tauangle(intertyp,i))
8355           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
8356           esccor=esccor+v1ij*cosphi+v2ij*sinphi
8357           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
8358         enddo
8359         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
8360                                 'esccor',i,intertyp,esccor_ii
8361 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
8362         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
8363         if (lprn) &
8364         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
8365         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
8366         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
8367         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
8368         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
8369        enddo !intertyp
8370       enddo
8371
8372       return
8373       end subroutine eback_sc_corr
8374 !-----------------------------------------------------------------------------
8375       subroutine multibody(ecorr)
8376 ! This subroutine calculates multi-body contributions to energy following
8377 ! the idea of Skolnick et al. If side chains I and J make a contact and
8378 ! at the same time side chains I+1 and J+1 make a contact, an extra
8379 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
8380 !      implicit real*8 (a-h,o-z)
8381 !      include 'DIMENSIONS'
8382 !      include 'COMMON.IOUNITS'
8383 !      include 'COMMON.DERIV'
8384 !      include 'COMMON.INTERACT'
8385 !      include 'COMMON.CONTACTS'
8386       real(kind=8),dimension(3) :: gx,gx1
8387       logical :: lprn
8388       real(kind=8) :: ecorr
8389       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
8390 ! Set lprn=.true. for debugging
8391       lprn=.false.
8392
8393       if (lprn) then
8394         write (iout,'(a)') 'Contact function values:'
8395         do i=nnt,nct-2
8396           write (iout,'(i2,20(1x,i2,f10.5))') &
8397               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8398         enddo
8399       endif
8400       ecorr=0.0D0
8401
8402 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8403 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8404       do i=nnt,nct
8405         do j=1,3
8406           gradcorr(j,i)=0.0D0
8407           gradxorr(j,i)=0.0D0
8408         enddo
8409       enddo
8410       do i=nnt,nct-2
8411
8412         DO ISHIFT = 3,4
8413
8414         i1=i+ishift
8415         num_conti=num_cont(i)
8416         num_conti1=num_cont(i1)
8417         do jj=1,num_conti
8418           j=jcont(jj,i)
8419           do kk=1,num_conti1
8420             j1=jcont(kk,i1)
8421             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8422 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8423 !d   &                   ' ishift=',ishift
8424 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8425 ! The system gains extra energy.
8426               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8427             endif   ! j1==j+-ishift
8428           enddo     ! kk
8429         enddo       ! jj
8430
8431         ENDDO ! ISHIFT
8432
8433       enddo         ! i
8434       return
8435       end subroutine multibody
8436 !-----------------------------------------------------------------------------
8437       real(kind=8) function esccorr(i,j,k,l,jj,kk)
8438 !      implicit real*8 (a-h,o-z)
8439 !      include 'DIMENSIONS'
8440 !      include 'COMMON.IOUNITS'
8441 !      include 'COMMON.DERIV'
8442 !      include 'COMMON.INTERACT'
8443 !      include 'COMMON.CONTACTS'
8444       real(kind=8),dimension(3) :: gx,gx1
8445       logical :: lprn
8446       integer :: i,j,k,l,jj,kk,m,ll
8447       real(kind=8) :: eij,ekl
8448       lprn=.false.
8449       eij=facont(jj,i)
8450       ekl=facont(kk,k)
8451 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8452 ! Calculate the multi-body contribution to energy.
8453 ! Calculate multi-body contributions to the gradient.
8454 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8455 !d   & k,l,(gacont(m,kk,k),m=1,3)
8456       do m=1,3
8457         gx(m) =ekl*gacont(m,jj,i)
8458         gx1(m)=eij*gacont(m,kk,k)
8459         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8460         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8461         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8462         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8463       enddo
8464       do m=i,j-1
8465         do ll=1,3
8466           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8467         enddo
8468       enddo
8469       do m=k,l-1
8470         do ll=1,3
8471           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8472         enddo
8473       enddo
8474       esccorr=-eij*ekl
8475       return
8476       end function esccorr
8477 !-----------------------------------------------------------------------------
8478       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8479 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8480 !      implicit real*8 (a-h,o-z)
8481 !      include 'DIMENSIONS'
8482 !      include 'COMMON.IOUNITS'
8483 #ifdef MPI
8484       include "mpif.h"
8485 !      integer :: maxconts !max_cont=maxconts  =nres/4
8486       integer,parameter :: max_dim=26
8487       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8488       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8489 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8490 !el      common /przechowalnia/ zapas
8491       integer :: status(MPI_STATUS_SIZE)
8492       integer,dimension((nres/4)*2) :: req !maxconts*2
8493       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
8494 #endif
8495 !      include 'COMMON.SETUP'
8496 !      include 'COMMON.FFIELD'
8497 !      include 'COMMON.DERIV'
8498 !      include 'COMMON.INTERACT'
8499 !      include 'COMMON.CONTACTS'
8500 !      include 'COMMON.CONTROL'
8501 !      include 'COMMON.LOCAL'
8502       real(kind=8),dimension(3) :: gx,gx1
8503       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
8504       logical :: lprn,ldone
8505 !el local variables
8506       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
8507               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
8508
8509 ! Set lprn=.true. for debugging
8510       lprn=.false.
8511 #ifdef MPI
8512 !      maxconts=nres/4
8513       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8514       n_corr=0
8515       n_corr1=0
8516       if (nfgtasks.le.1) goto 30
8517       if (lprn) then
8518         write (iout,'(a)') 'Contact function values before RECEIVE:'
8519         do i=nnt,nct-2
8520           write (iout,'(2i3,50(1x,i2,f5.2))') &
8521           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8522           j=1,num_cont_hb(i))
8523         enddo
8524       endif
8525       call flush(iout)
8526       do i=1,ntask_cont_from
8527         ncont_recv(i)=0
8528       enddo
8529       do i=1,ntask_cont_to
8530         ncont_sent(i)=0
8531       enddo
8532 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8533 !     & ntask_cont_to
8534 ! Make the list of contacts to send to send to other procesors
8535 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8536 !      call flush(iout)
8537       do i=iturn3_start,iturn3_end
8538 !        write (iout,*) "make contact list turn3",i," num_cont",
8539 !     &    num_cont_hb(i)
8540         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8541       enddo
8542       do i=iturn4_start,iturn4_end
8543 !        write (iout,*) "make contact list turn4",i," num_cont",
8544 !     &   num_cont_hb(i)
8545         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8546       enddo
8547       do ii=1,nat_sent
8548         i=iat_sent(ii)
8549 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8550 !     &    num_cont_hb(i)
8551         do j=1,num_cont_hb(i)
8552         do k=1,4
8553           jjc=jcont_hb(j,i)
8554           iproc=iint_sent_local(k,jjc,ii)
8555 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8556           if (iproc.gt.0) then
8557             ncont_sent(iproc)=ncont_sent(iproc)+1
8558             nn=ncont_sent(iproc)
8559             zapas(1,nn,iproc)=i
8560             zapas(2,nn,iproc)=jjc
8561             zapas(3,nn,iproc)=facont_hb(j,i)
8562             zapas(4,nn,iproc)=ees0p(j,i)
8563             zapas(5,nn,iproc)=ees0m(j,i)
8564             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8565             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8566             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8567             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8568             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8569             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8570             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8571             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8572             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8573             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8574             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8575             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8576             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8577             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8578             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8579             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8580             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8581             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8582             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8583             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8584             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8585           endif
8586         enddo
8587         enddo
8588       enddo
8589       if (lprn) then
8590       write (iout,*) &
8591         "Numbers of contacts to be sent to other processors",&
8592         (ncont_sent(i),i=1,ntask_cont_to)
8593       write (iout,*) "Contacts sent"
8594       do ii=1,ntask_cont_to
8595         nn=ncont_sent(ii)
8596         iproc=itask_cont_to(ii)
8597         write (iout,*) nn," contacts to processor",iproc,&
8598          " of CONT_TO_COMM group"
8599         do i=1,nn
8600           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8601         enddo
8602       enddo
8603       call flush(iout)
8604       endif
8605       CorrelType=477
8606       CorrelID=fg_rank+1
8607       CorrelType1=478
8608       CorrelID1=nfgtasks+fg_rank+1
8609       ireq=0
8610 ! Receive the numbers of needed contacts from other processors
8611       do ii=1,ntask_cont_from
8612         iproc=itask_cont_from(ii)
8613         ireq=ireq+1
8614         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8615           FG_COMM,req(ireq),IERR)
8616       enddo
8617 !      write (iout,*) "IRECV ended"
8618 !      call flush(iout)
8619 ! Send the number of contacts needed by other processors
8620       do ii=1,ntask_cont_to
8621         iproc=itask_cont_to(ii)
8622         ireq=ireq+1
8623         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8624           FG_COMM,req(ireq),IERR)
8625       enddo
8626 !      write (iout,*) "ISEND ended"
8627 !      write (iout,*) "number of requests (nn)",ireq
8628       call flush(iout)
8629       if (ireq.gt.0) &
8630         call MPI_Waitall(ireq,req,status_array,ierr)
8631 !      write (iout,*)
8632 !     &  "Numbers of contacts to be received from other processors",
8633 !     &  (ncont_recv(i),i=1,ntask_cont_from)
8634 !      call flush(iout)
8635 ! Receive contacts
8636       ireq=0
8637       do ii=1,ntask_cont_from
8638         iproc=itask_cont_from(ii)
8639         nn=ncont_recv(ii)
8640 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8641 !     &   " of CONT_TO_COMM group"
8642         call flush(iout)
8643         if (nn.gt.0) then
8644           ireq=ireq+1
8645           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
8646           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8647 !          write (iout,*) "ireq,req",ireq,req(ireq)
8648         endif
8649       enddo
8650 ! Send the contacts to processors that need them
8651       do ii=1,ntask_cont_to
8652         iproc=itask_cont_to(ii)
8653         nn=ncont_sent(ii)
8654 !        write (iout,*) nn," contacts to processor",iproc,
8655 !     &   " of CONT_TO_COMM group"
8656         if (nn.gt.0) then
8657           ireq=ireq+1
8658           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
8659             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8660 !          write (iout,*) "ireq,req",ireq,req(ireq)
8661 !          do i=1,nn
8662 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8663 !          enddo
8664         endif
8665       enddo
8666 !      write (iout,*) "number of requests (contacts)",ireq
8667 !      write (iout,*) "req",(req(i),i=1,4)
8668 !      call flush(iout)
8669       if (ireq.gt.0) &
8670        call MPI_Waitall(ireq,req,status_array,ierr)
8671       do iii=1,ntask_cont_from
8672         iproc=itask_cont_from(iii)
8673         nn=ncont_recv(iii)
8674         if (lprn) then
8675         write (iout,*) "Received",nn," contacts from processor",iproc,&
8676          " of CONT_FROM_COMM group"
8677         call flush(iout)
8678         do i=1,nn
8679           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8680         enddo
8681         call flush(iout)
8682         endif
8683         do i=1,nn
8684           ii=zapas_recv(1,i,iii)
8685 ! Flag the received contacts to prevent double-counting
8686           jj=-zapas_recv(2,i,iii)
8687 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8688 !          call flush(iout)
8689           nnn=num_cont_hb(ii)+1
8690           num_cont_hb(ii)=nnn
8691           jcont_hb(nnn,ii)=jj
8692           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8693           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8694           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8695           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8696           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8697           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8698           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8699           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8700           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8701           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8702           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8703           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8704           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8705           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8706           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8707           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8708           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8709           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8710           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8711           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8712           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8713           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8714           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8715           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8716         enddo
8717       enddo
8718       call flush(iout)
8719       if (lprn) then
8720         write (iout,'(a)') 'Contact function values after receive:'
8721         do i=nnt,nct-2
8722           write (iout,'(2i3,50(1x,i3,f5.2))') &
8723           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8724           j=1,num_cont_hb(i))
8725         enddo
8726         call flush(iout)
8727       endif
8728    30 continue
8729 #endif
8730       if (lprn) then
8731         write (iout,'(a)') 'Contact function values:'
8732         do i=nnt,nct-2
8733           write (iout,'(2i3,50(1x,i3,f5.2))') &
8734           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8735           j=1,num_cont_hb(i))
8736         enddo
8737       endif
8738       ecorr=0.0D0
8739
8740 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8741 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8742 ! Remove the loop below after debugging !!!
8743       do i=nnt,nct
8744         do j=1,3
8745           gradcorr(j,i)=0.0D0
8746           gradxorr(j,i)=0.0D0
8747         enddo
8748       enddo
8749 ! Calculate the local-electrostatic correlation terms
8750       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8751         i1=i+1
8752         num_conti=num_cont_hb(i)
8753         num_conti1=num_cont_hb(i+1)
8754         do jj=1,num_conti
8755           j=jcont_hb(jj,i)
8756           jp=iabs(j)
8757           do kk=1,num_conti1
8758             j1=jcont_hb(kk,i1)
8759             jp1=iabs(j1)
8760 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
8761 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
8762             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8763                 .or. j.lt.0 .and. j1.gt.0) .and. &
8764                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8765 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8766 ! The system gains extra energy.
8767               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8768               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
8769                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8770               n_corr=n_corr+1
8771             else if (j1.eq.j) then
8772 ! Contacts I-J and I-(J+1) occur simultaneously.
8773 ! The system loses extra energy.
8774 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8775             endif
8776           enddo ! kk
8777           do kk=1,num_conti
8778             j1=jcont_hb(kk,i)
8779 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8780 !    &         ' jj=',jj,' kk=',kk
8781             if (j1.eq.j+1) then
8782 ! Contacts I-J and (I+1)-J occur simultaneously.
8783 ! The system loses extra energy.
8784 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8785             endif ! j1==j+1
8786           enddo ! kk
8787         enddo ! jj
8788       enddo ! i
8789       return
8790       end subroutine multibody_hb
8791 !-----------------------------------------------------------------------------
8792       subroutine add_hb_contact(ii,jj,itask)
8793 !      implicit real*8 (a-h,o-z)
8794 !      include "DIMENSIONS"
8795 !      include "COMMON.IOUNITS"
8796 !      include "COMMON.CONTACTS"
8797 !      integer,parameter :: maxconts=nres/4
8798       integer,parameter :: max_dim=26
8799       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8800 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
8801 !      common /przechowalnia/ zapas
8802       integer :: i,j,ii,jj,iproc,nn,jjc
8803       integer,dimension(4) :: itask
8804 !      write (iout,*) "itask",itask
8805       do i=1,2
8806         iproc=itask(i)
8807         if (iproc.gt.0) then
8808           do j=1,num_cont_hb(ii)
8809             jjc=jcont_hb(j,ii)
8810 !            write (iout,*) "i",ii," j",jj," jjc",jjc
8811             if (jjc.eq.jj) then
8812               ncont_sent(iproc)=ncont_sent(iproc)+1
8813               nn=ncont_sent(iproc)
8814               zapas(1,nn,iproc)=ii
8815               zapas(2,nn,iproc)=jjc
8816               zapas(3,nn,iproc)=facont_hb(j,ii)
8817               zapas(4,nn,iproc)=ees0p(j,ii)
8818               zapas(5,nn,iproc)=ees0m(j,ii)
8819               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8820               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8821               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8822               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8823               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8824               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8825               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8826               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8827               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8828               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8829               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8830               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8831               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8832               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8833               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8834               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8835               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8836               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8837               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8838               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8839               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8840               exit
8841             endif
8842           enddo
8843         endif
8844       enddo
8845       return
8846       end subroutine add_hb_contact
8847 !-----------------------------------------------------------------------------
8848       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
8849 ! This subroutine calculates multi-body contributions to hydrogen-bonding
8850 !      implicit real*8 (a-h,o-z)
8851 !      include 'DIMENSIONS'
8852 !      include 'COMMON.IOUNITS'
8853       integer,parameter :: max_dim=70
8854 #ifdef MPI
8855       include "mpif.h"
8856 !      integer :: maxconts !max_cont=maxconts=nres/4
8857       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8858       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8859 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8860 !      common /przechowalnia/ zapas
8861       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
8862         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
8863         ierr,iii,nnn
8864 #endif
8865 !      include 'COMMON.SETUP'
8866 !      include 'COMMON.FFIELD'
8867 !      include 'COMMON.DERIV'
8868 !      include 'COMMON.LOCAL'
8869 !      include 'COMMON.INTERACT'
8870 !      include 'COMMON.CONTACTS'
8871 !      include 'COMMON.CHAIN'
8872 !      include 'COMMON.CONTROL'
8873       real(kind=8),dimension(3) :: gx,gx1
8874       integer,dimension(nres) :: num_cont_hb_old
8875       logical :: lprn,ldone
8876 !EL      double precision eello4,eello5,eelo6,eello_turn6
8877 !EL      external eello4,eello5,eello6,eello_turn6
8878 !el local variables
8879       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
8880               j1,jp1,i1,num_conti1
8881       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
8882       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
8883
8884 ! Set lprn=.true. for debugging
8885       lprn=.false.
8886       eturn6=0.0d0
8887 #ifdef MPI
8888 !      maxconts=nres/4
8889       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
8890       do i=1,nres
8891         num_cont_hb_old(i)=num_cont_hb(i)
8892       enddo
8893       n_corr=0
8894       n_corr1=0
8895       if (nfgtasks.le.1) goto 30
8896       if (lprn) then
8897         write (iout,'(a)') 'Contact function values before RECEIVE:'
8898         do i=nnt,nct-2
8899           write (iout,'(2i3,50(1x,i2,f5.2))') &
8900           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
8901           j=1,num_cont_hb(i))
8902         enddo
8903       endif
8904       call flush(iout)
8905       do i=1,ntask_cont_from
8906         ncont_recv(i)=0
8907       enddo
8908       do i=1,ntask_cont_to
8909         ncont_sent(i)=0
8910       enddo
8911 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8912 !     & ntask_cont_to
8913 ! Make the list of contacts to send to send to other procesors
8914       do i=iturn3_start,iturn3_end
8915 !        write (iout,*) "make contact list turn3",i," num_cont",
8916 !     &    num_cont_hb(i)
8917         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8918       enddo
8919       do i=iturn4_start,iturn4_end
8920 !        write (iout,*) "make contact list turn4",i," num_cont",
8921 !     &   num_cont_hb(i)
8922         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8923       enddo
8924       do ii=1,nat_sent
8925         i=iat_sent(ii)
8926 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
8927 !     &    num_cont_hb(i)
8928         do j=1,num_cont_hb(i)
8929         do k=1,4
8930           jjc=jcont_hb(j,i)
8931           iproc=iint_sent_local(k,jjc,ii)
8932 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8933           if (iproc.ne.0) then
8934             ncont_sent(iproc)=ncont_sent(iproc)+1
8935             nn=ncont_sent(iproc)
8936             zapas(1,nn,iproc)=i
8937             zapas(2,nn,iproc)=jjc
8938             zapas(3,nn,iproc)=d_cont(j,i)
8939             ind=3
8940             do kk=1,3
8941               ind=ind+1
8942               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8943             enddo
8944             do kk=1,2
8945               do ll=1,2
8946                 ind=ind+1
8947                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8948               enddo
8949             enddo
8950             do jj=1,5
8951               do kk=1,3
8952                 do ll=1,2
8953                   do mm=1,2
8954                     ind=ind+1
8955                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8956                   enddo
8957                 enddo
8958               enddo
8959             enddo
8960           endif
8961         enddo
8962         enddo
8963       enddo
8964       if (lprn) then
8965       write (iout,*) &
8966         "Numbers of contacts to be sent to other processors",&
8967         (ncont_sent(i),i=1,ntask_cont_to)
8968       write (iout,*) "Contacts sent"
8969       do ii=1,ntask_cont_to
8970         nn=ncont_sent(ii)
8971         iproc=itask_cont_to(ii)
8972         write (iout,*) nn," contacts to processor",iproc,&
8973          " of CONT_TO_COMM group"
8974         do i=1,nn
8975           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8976         enddo
8977       enddo
8978       call flush(iout)
8979       endif
8980       CorrelType=477
8981       CorrelID=fg_rank+1
8982       CorrelType1=478
8983       CorrelID1=nfgtasks+fg_rank+1
8984       ireq=0
8985 ! Receive the numbers of needed contacts from other processors
8986       do ii=1,ntask_cont_from
8987         iproc=itask_cont_from(ii)
8988         ireq=ireq+1
8989         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
8990           FG_COMM,req(ireq),IERR)
8991       enddo
8992 !      write (iout,*) "IRECV ended"
8993 !      call flush(iout)
8994 ! Send the number of contacts needed by other processors
8995       do ii=1,ntask_cont_to
8996         iproc=itask_cont_to(ii)
8997         ireq=ireq+1
8998         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
8999           FG_COMM,req(ireq),IERR)
9000       enddo
9001 !      write (iout,*) "ISEND ended"
9002 !      write (iout,*) "number of requests (nn)",ireq
9003       call flush(iout)
9004       if (ireq.gt.0) &
9005         call MPI_Waitall(ireq,req,status_array,ierr)
9006 !      write (iout,*)
9007 !     &  "Numbers of contacts to be received from other processors",
9008 !     &  (ncont_recv(i),i=1,ntask_cont_from)
9009 !      call flush(iout)
9010 ! Receive contacts
9011       ireq=0
9012       do ii=1,ntask_cont_from
9013         iproc=itask_cont_from(ii)
9014         nn=ncont_recv(ii)
9015 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
9016 !     &   " of CONT_TO_COMM group"
9017         call flush(iout)
9018         if (nn.gt.0) then
9019           ireq=ireq+1
9020           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
9021           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9022 !          write (iout,*) "ireq,req",ireq,req(ireq)
9023         endif
9024       enddo
9025 ! Send the contacts to processors that need them
9026       do ii=1,ntask_cont_to
9027         iproc=itask_cont_to(ii)
9028         nn=ncont_sent(ii)
9029 !        write (iout,*) nn," contacts to processor",iproc,
9030 !     &   " of CONT_TO_COMM group"
9031         if (nn.gt.0) then
9032           ireq=ireq+1
9033           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
9034             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
9035 !          write (iout,*) "ireq,req",ireq,req(ireq)
9036 !          do i=1,nn
9037 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
9038 !          enddo
9039         endif
9040       enddo
9041 !      write (iout,*) "number of requests (contacts)",ireq
9042 !      write (iout,*) "req",(req(i),i=1,4)
9043 !      call flush(iout)
9044       if (ireq.gt.0) &
9045        call MPI_Waitall(ireq,req,status_array,ierr)
9046       do iii=1,ntask_cont_from
9047         iproc=itask_cont_from(iii)
9048         nn=ncont_recv(iii)
9049         if (lprn) then
9050         write (iout,*) "Received",nn," contacts from processor",iproc,&
9051          " of CONT_FROM_COMM group"
9052         call flush(iout)
9053         do i=1,nn
9054           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
9055         enddo
9056         call flush(iout)
9057         endif
9058         do i=1,nn
9059           ii=zapas_recv(1,i,iii)
9060 ! Flag the received contacts to prevent double-counting
9061           jj=-zapas_recv(2,i,iii)
9062 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
9063 !          call flush(iout)
9064           nnn=num_cont_hb(ii)+1
9065           num_cont_hb(ii)=nnn
9066           jcont_hb(nnn,ii)=jj
9067           d_cont(nnn,ii)=zapas_recv(3,i,iii)
9068           ind=3
9069           do kk=1,3
9070             ind=ind+1
9071             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
9072           enddo
9073           do kk=1,2
9074             do ll=1,2
9075               ind=ind+1
9076               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
9077             enddo
9078           enddo
9079           do jj=1,5
9080             do kk=1,3
9081               do ll=1,2
9082                 do mm=1,2
9083                   ind=ind+1
9084                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
9085                 enddo
9086               enddo
9087             enddo
9088           enddo
9089         enddo
9090       enddo
9091       call flush(iout)
9092       if (lprn) then
9093         write (iout,'(a)') 'Contact function values after receive:'
9094         do i=nnt,nct-2
9095           write (iout,'(2i3,50(1x,i3,5f6.3))') &
9096           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
9097           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9098         enddo
9099         call flush(iout)
9100       endif
9101    30 continue
9102 #endif
9103       if (lprn) then
9104         write (iout,'(a)') 'Contact function values:'
9105         do i=nnt,nct-2
9106           write (iout,'(2i3,50(1x,i2,5f6.3))') &
9107           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
9108           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
9109         enddo
9110       endif
9111       ecorr=0.0D0
9112       ecorr5=0.0d0
9113       ecorr6=0.0d0
9114
9115 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
9116 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
9117 ! Remove the loop below after debugging !!!
9118       do i=nnt,nct
9119         do j=1,3
9120           gradcorr(j,i)=0.0D0
9121           gradxorr(j,i)=0.0D0
9122         enddo
9123       enddo
9124 ! Calculate the dipole-dipole interaction energies
9125       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
9126       do i=iatel_s,iatel_e+1
9127         num_conti=num_cont_hb(i)
9128         do jj=1,num_conti
9129           j=jcont_hb(jj,i)
9130 #ifdef MOMENT
9131           call dipole(i,j,jj)
9132 #endif
9133         enddo
9134       enddo
9135       endif
9136 ! Calculate the local-electrostatic correlation terms
9137 !                write (iout,*) "gradcorr5 in eello5 before loop"
9138 !                do iii=1,nres
9139 !                  write (iout,'(i5,3f10.5)')
9140 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9141 !                enddo
9142       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
9143 !        write (iout,*) "corr loop i",i
9144         i1=i+1
9145         num_conti=num_cont_hb(i)
9146         num_conti1=num_cont_hb(i+1)
9147         do jj=1,num_conti
9148           j=jcont_hb(jj,i)
9149           jp=iabs(j)
9150           do kk=1,num_conti1
9151             j1=jcont_hb(kk,i1)
9152             jp1=iabs(j1)
9153 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
9154 !     &         ' jj=',jj,' kk=',kk
9155 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
9156             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
9157                 .or. j.lt.0 .and. j1.gt.0) .and. &
9158                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
9159 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
9160 ! The system gains extra energy.
9161               n_corr=n_corr+1
9162               sqd1=dsqrt(d_cont(jj,i))
9163               sqd2=dsqrt(d_cont(kk,i1))
9164               sred_geom = sqd1*sqd2
9165               IF (sred_geom.lt.cutoff_corr) THEN
9166                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
9167                   ekont,fprimcont)
9168 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
9169 !d     &         ' jj=',jj,' kk=',kk
9170                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
9171                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
9172                 do l=1,3
9173                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
9174                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
9175                 enddo
9176                 n_corr1=n_corr1+1
9177 !d               write (iout,*) 'sred_geom=',sred_geom,
9178 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
9179 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
9180 !d               write (iout,*) "g_contij",g_contij
9181 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
9182 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
9183                 call calc_eello(i,jp,i+1,jp1,jj,kk)
9184                 if (wcorr4.gt.0.0d0) &
9185                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
9186                   if (energy_dec.and.wcorr4.gt.0.0d0) &
9187                        write (iout,'(a6,4i5,0pf7.3)') &
9188                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
9189 !                write (iout,*) "gradcorr5 before eello5"
9190 !                do iii=1,nres
9191 !                  write (iout,'(i5,3f10.5)')
9192 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9193 !                enddo
9194                 if (wcorr5.gt.0.0d0) &
9195                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
9196 !                write (iout,*) "gradcorr5 after eello5"
9197 !                do iii=1,nres
9198 !                  write (iout,'(i5,3f10.5)')
9199 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9200 !                enddo
9201                   if (energy_dec.and.wcorr5.gt.0.0d0) &
9202                        write (iout,'(a6,4i5,0pf7.3)') &
9203                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
9204 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
9205 !d                write(2,*)'ijkl',i,jp,i+1,jp1
9206                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
9207                      .or. wturn6.eq.0.0d0))then
9208 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
9209                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
9210                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
9211                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
9212 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
9213 !d     &            'ecorr6=',ecorr6
9214 !d                write (iout,'(4e15.5)') sred_geom,
9215 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
9216 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
9217 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
9218                 else if (wturn6.gt.0.0d0 &
9219                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
9220 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
9221                   eturn6=eturn6+eello_turn6(i,jj,kk)
9222                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
9223                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
9224 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
9225                 endif
9226               ENDIF
9227 1111          continue
9228             endif
9229           enddo ! kk
9230         enddo ! jj
9231       enddo ! i
9232       do i=1,nres
9233         num_cont_hb(i)=num_cont_hb_old(i)
9234       enddo
9235 !                write (iout,*) "gradcorr5 in eello5"
9236 !                do iii=1,nres
9237 !                  write (iout,'(i5,3f10.5)')
9238 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
9239 !                enddo
9240       return
9241       end subroutine multibody_eello
9242 !-----------------------------------------------------------------------------
9243       subroutine add_hb_contact_eello(ii,jj,itask)
9244 !      implicit real*8 (a-h,o-z)
9245 !      include "DIMENSIONS"
9246 !      include "COMMON.IOUNITS"
9247 !      include "COMMON.CONTACTS"
9248 !      integer,parameter :: maxconts=nres/4
9249       integer,parameter :: max_dim=70
9250       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
9251 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
9252 !      common /przechowalnia/ zapas
9253
9254       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
9255       integer,dimension(4) ::itask
9256 !      write (iout,*) "itask",itask
9257       do i=1,2
9258         iproc=itask(i)
9259         if (iproc.gt.0) then
9260           do j=1,num_cont_hb(ii)
9261             jjc=jcont_hb(j,ii)
9262 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
9263             if (jjc.eq.jj) then
9264               ncont_sent(iproc)=ncont_sent(iproc)+1
9265               nn=ncont_sent(iproc)
9266               zapas(1,nn,iproc)=ii
9267               zapas(2,nn,iproc)=jjc
9268               zapas(3,nn,iproc)=d_cont(j,ii)
9269               ind=3
9270               do kk=1,3
9271                 ind=ind+1
9272                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
9273               enddo
9274               do kk=1,2
9275                 do ll=1,2
9276                   ind=ind+1
9277                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
9278                 enddo
9279               enddo
9280               do jj=1,5
9281                 do kk=1,3
9282                   do ll=1,2
9283                     do mm=1,2
9284                       ind=ind+1
9285                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
9286                     enddo
9287                   enddo
9288                 enddo
9289               enddo
9290               exit
9291             endif
9292           enddo
9293         endif
9294       enddo
9295       return
9296       end subroutine add_hb_contact_eello
9297 !-----------------------------------------------------------------------------
9298       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
9299 !      implicit real*8 (a-h,o-z)
9300 !      include 'DIMENSIONS'
9301 !      include 'COMMON.IOUNITS'
9302 !      include 'COMMON.DERIV'
9303 !      include 'COMMON.INTERACT'
9304 !      include 'COMMON.CONTACTS'
9305       real(kind=8),dimension(3) :: gx,gx1
9306       logical :: lprn
9307 !el local variables
9308       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
9309       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
9310                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
9311                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
9312                    rlocshield
9313
9314       lprn=.false.
9315       eij=facont_hb(jj,i)
9316       ekl=facont_hb(kk,k)
9317       ees0pij=ees0p(jj,i)
9318       ees0pkl=ees0p(kk,k)
9319       ees0mij=ees0m(jj,i)
9320       ees0mkl=ees0m(kk,k)
9321       ekont=eij*ekl
9322       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
9323 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
9324 ! Following 4 lines for diagnostics.
9325 !d    ees0pkl=0.0D0
9326 !d    ees0pij=1.0D0
9327 !d    ees0mkl=0.0D0
9328 !d    ees0mij=1.0D0
9329 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
9330 !     & 'Contacts ',i,j,
9331 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
9332 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
9333 !     & 'gradcorr_long'
9334 ! Calculate the multi-body contribution to energy.
9335 !      ecorr=ecorr+ekont*ees
9336 ! Calculate multi-body contributions to the gradient.
9337       coeffpees0pij=coeffp*ees0pij
9338       coeffmees0mij=coeffm*ees0mij
9339       coeffpees0pkl=coeffp*ees0pkl
9340       coeffmees0mkl=coeffm*ees0mkl
9341       do ll=1,3
9342 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
9343         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
9344         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
9345         coeffmees0mkl*gacontm_hb1(ll,jj,i))
9346         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
9347         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
9348         coeffmees0mkl*gacontm_hb2(ll,jj,i))
9349 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
9350         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
9351         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
9352         coeffmees0mij*gacontm_hb1(ll,kk,k))
9353         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
9354         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
9355         coeffmees0mij*gacontm_hb2(ll,kk,k))
9356         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
9357            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
9358            coeffmees0mkl*gacontm_hb3(ll,jj,i))
9359         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
9360         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
9361         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
9362            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
9363            coeffmees0mij*gacontm_hb3(ll,kk,k))
9364         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
9365         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
9366 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
9367       enddo
9368 !      write (iout,*)
9369 !grad      do m=i+1,j-1
9370 !grad        do ll=1,3
9371 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
9372 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
9373 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
9374 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
9375 !grad        enddo
9376 !grad      enddo
9377 !grad      do m=k+1,l-1
9378 !grad        do ll=1,3
9379 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
9380 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
9381 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
9382 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
9383 !grad        enddo
9384 !grad      enddo
9385 !      write (iout,*) "ehbcorr",ekont*ees
9386       ehbcorr=ekont*ees
9387       if (shield_mode.gt.0) then
9388        j=ees0plist(jj,i)
9389        l=ees0plist(kk,k)
9390 !C        print *,i,j,fac_shield(i),fac_shield(j),
9391 !C     &fac_shield(k),fac_shield(l)
9392         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
9393            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
9394           do ilist=1,ishield_list(i)
9395            iresshield=shield_list(ilist,i)
9396            do m=1,3
9397            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
9398            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
9399                    rlocshield  &
9400             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
9401             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
9402             +rlocshield
9403            enddo
9404           enddo
9405           do ilist=1,ishield_list(j)
9406            iresshield=shield_list(ilist,j)
9407            do m=1,3
9408            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
9409            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
9410                    rlocshield &
9411             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9412            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
9413             +rlocshield
9414            enddo
9415           enddo
9416
9417           do ilist=1,ishield_list(k)
9418            iresshield=shield_list(ilist,k)
9419            do m=1,3
9420            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9421            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
9422                    rlocshield &
9423             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9424            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
9425             +rlocshield
9426            enddo
9427           enddo
9428           do ilist=1,ishield_list(l)
9429            iresshield=shield_list(ilist,l)
9430            do m=1,3
9431            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9432            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
9433                    rlocshield &
9434             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9435            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
9436             +rlocshield
9437            enddo
9438           enddo
9439           do m=1,3
9440             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
9441                    grad_shield(m,i)*ehbcorr/fac_shield(i)
9442             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
9443                    grad_shield(m,j)*ehbcorr/fac_shield(j)
9444             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
9445                    grad_shield(m,i)*ehbcorr/fac_shield(i)
9446             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
9447                    grad_shield(m,j)*ehbcorr/fac_shield(j)
9448
9449             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
9450                    grad_shield(m,k)*ehbcorr/fac_shield(k)
9451             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
9452                    grad_shield(m,l)*ehbcorr/fac_shield(l)
9453             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
9454                    grad_shield(m,k)*ehbcorr/fac_shield(k)
9455             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
9456                    grad_shield(m,l)*ehbcorr/fac_shield(l)
9457
9458            enddo
9459       endif
9460       endif
9461       return
9462       end function ehbcorr
9463 #ifdef MOMENT
9464 !-----------------------------------------------------------------------------
9465       subroutine dipole(i,j,jj)
9466 !      implicit real*8 (a-h,o-z)
9467 !      include 'DIMENSIONS'
9468 !      include 'COMMON.IOUNITS'
9469 !      include 'COMMON.CHAIN'
9470 !      include 'COMMON.FFIELD'
9471 !      include 'COMMON.DERIV'
9472 !      include 'COMMON.INTERACT'
9473 !      include 'COMMON.CONTACTS'
9474 !      include 'COMMON.TORSION'
9475 !      include 'COMMON.VAR'
9476 !      include 'COMMON.GEO'
9477       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
9478       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
9479       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
9480
9481       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
9482       allocate(dipderx(3,5,4,maxconts,nres))
9483 !
9484
9485       iti1 = itortyp(itype(i+1,1))
9486       if (j.lt.nres-1) then
9487         itj1 = itype2loc(itype(j+1,1))
9488       else
9489         itj1=nloctyp
9490       endif
9491       do iii=1,2
9492         dipi(iii,1)=Ub2(iii,i)
9493         dipderi(iii)=Ub2der(iii,i)
9494         dipi(iii,2)=b1(iii,iti1)
9495         dipj(iii,1)=Ub2(iii,j)
9496         dipderj(iii)=Ub2der(iii,j)
9497         dipj(iii,2)=b1(iii,itj1)
9498       enddo
9499       kkk=0
9500       do iii=1,2
9501         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9502         do jjj=1,2
9503           kkk=kkk+1
9504           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9505         enddo
9506       enddo
9507       do kkk=1,5
9508         do lll=1,3
9509           mmm=0
9510           do iii=1,2
9511             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
9512               auxvec(1))
9513             do jjj=1,2
9514               mmm=mmm+1
9515               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9516             enddo
9517           enddo
9518         enddo
9519       enddo
9520       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9521       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9522       do iii=1,2
9523         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9524       enddo
9525       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9526       do iii=1,2
9527         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9528       enddo
9529       return
9530       end subroutine dipole
9531 #endif
9532 !-----------------------------------------------------------------------------
9533       subroutine calc_eello(i,j,k,l,jj,kk)
9534 !
9535 ! This subroutine computes matrices and vectors needed to calculate
9536 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
9537 !
9538       use comm_kut
9539 !      implicit real*8 (a-h,o-z)
9540 !      include 'DIMENSIONS'
9541 !      include 'COMMON.IOUNITS'
9542 !      include 'COMMON.CHAIN'
9543 !      include 'COMMON.DERIV'
9544 !      include 'COMMON.INTERACT'
9545 !      include 'COMMON.CONTACTS'
9546 !      include 'COMMON.TORSION'
9547 !      include 'COMMON.VAR'
9548 !      include 'COMMON.GEO'
9549 !      include 'COMMON.FFIELD'
9550       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
9551       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
9552       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
9553               itj1
9554 !el      logical :: lprn
9555 !el      common /kutas/ lprn
9556 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9557 !d     & ' jj=',jj,' kk=',kk
9558 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9559 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9560 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9561       do iii=1,2
9562         do jjj=1,2
9563           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9564           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9565         enddo
9566       enddo
9567       call transpose2(aa1(1,1),aa1t(1,1))
9568       call transpose2(aa2(1,1),aa2t(1,1))
9569       do kkk=1,5
9570         do lll=1,3
9571           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
9572             aa1tder(1,1,lll,kkk))
9573           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
9574             aa2tder(1,1,lll,kkk))
9575         enddo
9576       enddo
9577       if (l.eq.j+1) then
9578 ! parallel orientation of the two CA-CA-CA frames.
9579         if (i.gt.1) then
9580           iti=itortyp(itype(i,1))
9581         else
9582           iti=ntortyp+1
9583         endif
9584         itk1=itortyp(itype(k+1,1))
9585         itj=itortyp(itype(j,1))
9586         if (l.lt.nres-1) then
9587           itl1=itortyp(itype(l+1,1))
9588         else
9589           itl1=ntortyp+1
9590         endif
9591 ! A1 kernel(j+1) A2T
9592 !d        do iii=1,2
9593 !d          write (iout,'(3f10.5,5x,3f10.5)')
9594 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9595 !d        enddo
9596         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9597          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
9598          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9599 ! Following matrices are needed only for 6-th order cumulants
9600         IF (wcorr6.gt.0.0d0) THEN
9601         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9602          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
9603          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9604         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9605          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
9606          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9607          ADtEAderx(1,1,1,1,1,1))
9608         lprn=.false.
9609         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9610          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
9611          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9612          ADtEA1derx(1,1,1,1,1,1))
9613         ENDIF
9614 ! End 6-th order cumulants
9615 !d        lprn=.false.
9616 !d        if (lprn) then
9617 !d        write (2,*) 'In calc_eello6'
9618 !d        do iii=1,2
9619 !d          write (2,*) 'iii=',iii
9620 !d          do kkk=1,5
9621 !d            write (2,*) 'kkk=',kkk
9622 !d            do jjj=1,2
9623 !d              write (2,'(3(2f10.5),5x)')
9624 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9625 !d            enddo
9626 !d          enddo
9627 !d        enddo
9628 !d        endif
9629         call transpose2(EUgder(1,1,k),auxmat(1,1))
9630         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9631         call transpose2(EUg(1,1,k),auxmat(1,1))
9632         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9633         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9634         do iii=1,2
9635           do kkk=1,5
9636             do lll=1,3
9637               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9638                 EAEAderx(1,1,lll,kkk,iii,1))
9639             enddo
9640           enddo
9641         enddo
9642 ! A1T kernel(i+1) A2
9643         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9644          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
9645          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9646 ! Following matrices are needed only for 6-th order cumulants
9647         IF (wcorr6.gt.0.0d0) THEN
9648         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9649          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
9650          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9651         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9652          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
9653          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9654          ADtEAderx(1,1,1,1,1,2))
9655         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
9656          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
9657          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9658          ADtEA1derx(1,1,1,1,1,2))
9659         ENDIF
9660 ! End 6-th order cumulants
9661         call transpose2(EUgder(1,1,l),auxmat(1,1))
9662         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9663         call transpose2(EUg(1,1,l),auxmat(1,1))
9664         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9665         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9666         do iii=1,2
9667           do kkk=1,5
9668             do lll=1,3
9669               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9670                 EAEAderx(1,1,lll,kkk,iii,2))
9671             enddo
9672           enddo
9673         enddo
9674 ! AEAb1 and AEAb2
9675 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9676 ! They are needed only when the fifth- or the sixth-order cumulants are
9677 ! indluded.
9678         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9679         call transpose2(AEA(1,1,1),auxmat(1,1))
9680         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9681         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9682         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9683         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9684         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9685         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9686         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9687         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9688         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9689         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9690         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9691         call transpose2(AEA(1,1,2),auxmat(1,1))
9692         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
9693         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9694         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9695         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9696         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
9697         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9698         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
9699         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
9700         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9701         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9702         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9703 ! Calculate the Cartesian derivatives of the vectors.
9704         do iii=1,2
9705           do kkk=1,5
9706             do lll=1,3
9707               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9708               call matvec2(auxmat(1,1),b1(1,iti),&
9709                 AEAb1derx(1,lll,kkk,iii,1,1))
9710               call matvec2(auxmat(1,1),Ub2(1,i),&
9711                 AEAb2derx(1,lll,kkk,iii,1,1))
9712               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9713                 AEAb1derx(1,lll,kkk,iii,2,1))
9714               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9715                 AEAb2derx(1,lll,kkk,iii,2,1))
9716               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9717               call matvec2(auxmat(1,1),b1(1,itj),&
9718                 AEAb1derx(1,lll,kkk,iii,1,2))
9719               call matvec2(auxmat(1,1),Ub2(1,j),&
9720                 AEAb2derx(1,lll,kkk,iii,1,2))
9721               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9722                 AEAb1derx(1,lll,kkk,iii,2,2))
9723               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
9724                 AEAb2derx(1,lll,kkk,iii,2,2))
9725             enddo
9726           enddo
9727         enddo
9728         ENDIF
9729 ! End vectors
9730       else
9731 ! Antiparallel orientation of the two CA-CA-CA frames.
9732         if (i.gt.1) then
9733           iti=itortyp(itype(i,1))
9734         else
9735           iti=ntortyp+1
9736         endif
9737         itk1=itortyp(itype(k+1,1))
9738         itl=itortyp(itype(l,1))
9739         itj=itortyp(itype(j,1))
9740         if (j.lt.nres-1) then
9741           itj1=itortyp(itype(j+1,1))
9742         else
9743           itj1=ntortyp+1
9744         endif
9745 ! A2 kernel(j-1)T A1T
9746         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9747          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
9748          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9749 ! Following matrices are needed only for 6-th order cumulants
9750         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9751            j.eq.i+4 .and. l.eq.i+3)) THEN
9752         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9753          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
9754          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9755         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9756          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
9757          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
9758          ADtEAderx(1,1,1,1,1,1))
9759         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
9760          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
9761          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
9762          ADtEA1derx(1,1,1,1,1,1))
9763         ENDIF
9764 ! End 6-th order cumulants
9765         call transpose2(EUgder(1,1,k),auxmat(1,1))
9766         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9767         call transpose2(EUg(1,1,k),auxmat(1,1))
9768         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9769         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9770         do iii=1,2
9771           do kkk=1,5
9772             do lll=1,3
9773               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9774                 EAEAderx(1,1,lll,kkk,iii,1))
9775             enddo
9776           enddo
9777         enddo
9778 ! A2T kernel(i+1)T A1
9779         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9780          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
9781          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9782 ! Following matrices are needed only for 6-th order cumulants
9783         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
9784            j.eq.i+4 .and. l.eq.i+3)) THEN
9785         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9786          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
9787          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9788         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9789          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
9790          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
9791          ADtEAderx(1,1,1,1,1,2))
9792         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
9793          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
9794          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
9795          ADtEA1derx(1,1,1,1,1,2))
9796         ENDIF
9797 ! End 6-th order cumulants
9798         call transpose2(EUgder(1,1,j),auxmat(1,1))
9799         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9800         call transpose2(EUg(1,1,j),auxmat(1,1))
9801         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9802         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9803         do iii=1,2
9804           do kkk=1,5
9805             do lll=1,3
9806               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9807                 EAEAderx(1,1,lll,kkk,iii,2))
9808             enddo
9809           enddo
9810         enddo
9811 ! AEAb1 and AEAb2
9812 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9813 ! They are needed only when the fifth- or the sixth-order cumulants are
9814 ! indluded.
9815         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
9816           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9817         call transpose2(AEA(1,1,1),auxmat(1,1))
9818         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
9819         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9820         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9821         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9822         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
9823         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9824         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
9825         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
9826         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9827         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9828         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9829         call transpose2(AEA(1,1,2),auxmat(1,1))
9830         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
9831         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9832         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9833         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9834         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
9835         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9836         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
9837         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
9838         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9839         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9840         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9841 ! Calculate the Cartesian derivatives of the vectors.
9842         do iii=1,2
9843           do kkk=1,5
9844             do lll=1,3
9845               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9846               call matvec2(auxmat(1,1),b1(1,iti),&
9847                 AEAb1derx(1,lll,kkk,iii,1,1))
9848               call matvec2(auxmat(1,1),Ub2(1,i),&
9849                 AEAb2derx(1,lll,kkk,iii,1,1))
9850               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9851                 AEAb1derx(1,lll,kkk,iii,2,1))
9852               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
9853                 AEAb2derx(1,lll,kkk,iii,2,1))
9854               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9855               call matvec2(auxmat(1,1),b1(1,itl),&
9856                 AEAb1derx(1,lll,kkk,iii,1,2))
9857               call matvec2(auxmat(1,1),Ub2(1,l),&
9858                 AEAb2derx(1,lll,kkk,iii,1,2))
9859               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
9860                 AEAb1derx(1,lll,kkk,iii,2,2))
9861               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
9862                 AEAb2derx(1,lll,kkk,iii,2,2))
9863             enddo
9864           enddo
9865         enddo
9866         ENDIF
9867 ! End vectors
9868       endif
9869       return
9870       end subroutine calc_eello
9871 !-----------------------------------------------------------------------------
9872       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
9873       use comm_kut
9874       implicit none
9875       integer :: nderg
9876       logical :: transp
9877       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
9878       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
9879       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
9880       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
9881       integer :: iii,kkk,lll
9882       integer :: jjj,mmm
9883 !el      logical :: lprn
9884 !el      common /kutas/ lprn
9885       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9886       do iii=1,nderg
9887         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
9888           AKAderg(1,1,iii))
9889       enddo
9890 !d      if (lprn) write (2,*) 'In kernel'
9891       do kkk=1,5
9892 !d        if (lprn) write (2,*) 'kkk=',kkk
9893         do lll=1,3
9894           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
9895             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9896 !d          if (lprn) then
9897 !d            write (2,*) 'lll=',lll
9898 !d            write (2,*) 'iii=1'
9899 !d            do jjj=1,2
9900 !d              write (2,'(3(2f10.5),5x)')
9901 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9902 !d            enddo
9903 !d          endif
9904           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
9905             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9906 !d          if (lprn) then
9907 !d            write (2,*) 'lll=',lll
9908 !d            write (2,*) 'iii=2'
9909 !d            do jjj=1,2
9910 !d              write (2,'(3(2f10.5),5x)')
9911 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9912 !d            enddo
9913 !d          endif
9914         enddo
9915       enddo
9916       return
9917       end subroutine kernel
9918 !-----------------------------------------------------------------------------
9919       real(kind=8) function eello4(i,j,k,l,jj,kk)
9920 !      implicit real*8 (a-h,o-z)
9921 !      include 'DIMENSIONS'
9922 !      include 'COMMON.IOUNITS'
9923 !      include 'COMMON.CHAIN'
9924 !      include 'COMMON.DERIV'
9925 !      include 'COMMON.INTERACT'
9926 !      include 'COMMON.CONTACTS'
9927 !      include 'COMMON.TORSION'
9928 !      include 'COMMON.VAR'
9929 !      include 'COMMON.GEO'
9930       real(kind=8),dimension(2,2) :: pizda
9931       real(kind=8),dimension(3) :: ggg1,ggg2
9932       real(kind=8) ::  eel4,glongij,glongkl
9933       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9934 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9935 !d        eello4=0.0d0
9936 !d        return
9937 !d      endif
9938 !d      print *,'eello4:',i,j,k,l,jj,kk
9939 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
9940 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
9941 !old      eij=facont_hb(jj,i)
9942 !old      ekl=facont_hb(kk,k)
9943 !old      ekont=eij*ekl
9944       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9945 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9946       gcorr_loc(k-1)=gcorr_loc(k-1) &
9947          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9948       if (l.eq.j+1) then
9949         gcorr_loc(l-1)=gcorr_loc(l-1) &
9950            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9951       else
9952         gcorr_loc(j-1)=gcorr_loc(j-1) &
9953            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9954       endif
9955       do iii=1,2
9956         do kkk=1,5
9957           do lll=1,3
9958             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
9959                               -EAEAderx(2,2,lll,kkk,iii,1)
9960 !d            derx(lll,kkk,iii)=0.0d0
9961           enddo
9962         enddo
9963       enddo
9964 !d      gcorr_loc(l-1)=0.0d0
9965 !d      gcorr_loc(j-1)=0.0d0
9966 !d      gcorr_loc(k-1)=0.0d0
9967 !d      eel4=1.0d0
9968 !d      write (iout,*)'Contacts have occurred for peptide groups',
9969 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9970 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9971       if (j.lt.nres-1) then
9972         j1=j+1
9973         j2=j-1
9974       else
9975         j1=j-1
9976         j2=j-2
9977       endif
9978       if (l.lt.nres-1) then
9979         l1=l+1
9980         l2=l-1
9981       else
9982         l1=l-1
9983         l2=l-2
9984       endif
9985       do ll=1,3
9986 !grad        ggg1(ll)=eel4*g_contij(ll,1)
9987 !grad        ggg2(ll)=eel4*g_contij(ll,2)
9988         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9989         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9990 !grad        ghalf=0.5d0*ggg1(ll)
9991         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9992         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9993         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9994         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9995         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9996         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9997 !grad        ghalf=0.5d0*ggg2(ll)
9998         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9999         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
10000         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
10001         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
10002         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
10003         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
10004       enddo
10005 !grad      do m=i+1,j-1
10006 !grad        do ll=1,3
10007 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
10008 !grad        enddo
10009 !grad      enddo
10010 !grad      do m=k+1,l-1
10011 !grad        do ll=1,3
10012 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
10013 !grad        enddo
10014 !grad      enddo
10015 !grad      do m=i+2,j2
10016 !grad        do ll=1,3
10017 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
10018 !grad        enddo
10019 !grad      enddo
10020 !grad      do m=k+2,l2
10021 !grad        do ll=1,3
10022 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
10023 !grad        enddo
10024 !grad      enddo
10025 !d      do iii=1,nres-3
10026 !d        write (2,*) iii,gcorr_loc(iii)
10027 !d      enddo
10028       eello4=ekont*eel4
10029 !d      write (2,*) 'ekont',ekont
10030 !d      write (iout,*) 'eello4',ekont*eel4
10031       return
10032       end function eello4
10033 !-----------------------------------------------------------------------------
10034       real(kind=8) function eello5(i,j,k,l,jj,kk)
10035 !      implicit real*8 (a-h,o-z)
10036 !      include 'DIMENSIONS'
10037 !      include 'COMMON.IOUNITS'
10038 !      include 'COMMON.CHAIN'
10039 !      include 'COMMON.DERIV'
10040 !      include 'COMMON.INTERACT'
10041 !      include 'COMMON.CONTACTS'
10042 !      include 'COMMON.TORSION'
10043 !      include 'COMMON.VAR'
10044 !      include 'COMMON.GEO'
10045       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10046       real(kind=8),dimension(2) :: vv
10047       real(kind=8),dimension(3) :: ggg1,ggg2
10048       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
10049       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
10050       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
10051 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10052 !                                                                              C
10053 !                            Parallel chains                                   C
10054 !                                                                              C
10055 !          o             o                   o             o                   C
10056 !         /l\           / \             \   / \           / \   /              C
10057 !        /   \         /   \             \ /   \         /   \ /               C
10058 !       j| o |l1       | o |                o| o |         | o |o                C
10059 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10060 !      \i/   \         /   \ /             /   \         /   \                 C
10061 !       o    k1             o                                                  C
10062 !         (I)          (II)                (III)          (IV)                 C
10063 !                                                                              C
10064 !      eello5_1        eello5_2            eello5_3       eello5_4             C
10065 !                                                                              C
10066 !                            Antiparallel chains                               C
10067 !                                                                              C
10068 !          o             o                   o             o                   C
10069 !         /j\           / \             \   / \           / \   /              C
10070 !        /   \         /   \             \ /   \         /   \ /               C
10071 !      j1| o |l        | o |                o| o |         | o |o                C
10072 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
10073 !      \i/   \         /   \ /             /   \         /   \                 C
10074 !       o     k1            o                                                  C
10075 !         (I)          (II)                (III)          (IV)                 C
10076 !                                                                              C
10077 !      eello5_1        eello5_2            eello5_3       eello5_4             C
10078 !                                                                              C
10079 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
10080 !                                                                              C
10081 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10082 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
10083 !d        eello5=0.0d0
10084 !d        return
10085 !d      endif
10086 !d      write (iout,*)
10087 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
10088 !d     &   ' and',k,l
10089       itk=itortyp(itype(k,1))
10090       itl=itortyp(itype(l,1))
10091       itj=itortyp(itype(j,1))
10092       eello5_1=0.0d0
10093       eello5_2=0.0d0
10094       eello5_3=0.0d0
10095       eello5_4=0.0d0
10096 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
10097 !d     &   eel5_3_num,eel5_4_num)
10098       do iii=1,2
10099         do kkk=1,5
10100           do lll=1,3
10101             derx(lll,kkk,iii)=0.0d0
10102           enddo
10103         enddo
10104       enddo
10105 !d      eij=facont_hb(jj,i)
10106 !d      ekl=facont_hb(kk,k)
10107 !d      ekont=eij*ekl
10108 !d      write (iout,*)'Contacts have occurred for peptide groups',
10109 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
10110 !d      goto 1111
10111 ! Contribution from the graph I.
10112 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
10113 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
10114       call transpose2(EUg(1,1,k),auxmat(1,1))
10115       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
10116       vv(1)=pizda(1,1)-pizda(2,2)
10117       vv(2)=pizda(1,2)+pizda(2,1)
10118       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
10119        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10120 ! Explicit gradient in virtual-dihedral angles.
10121       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
10122        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
10123        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
10124       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10125       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
10126       vv(1)=pizda(1,1)-pizda(2,2)
10127       vv(2)=pizda(1,2)+pizda(2,1)
10128       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10129        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
10130        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10131       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
10132       vv(1)=pizda(1,1)-pizda(2,2)
10133       vv(2)=pizda(1,2)+pizda(2,1)
10134       if (l.eq.j+1) then
10135         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10136          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
10137          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10138       else
10139         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10140          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
10141          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
10142       endif
10143 ! Cartesian gradient
10144       do iii=1,2
10145         do kkk=1,5
10146           do lll=1,3
10147             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
10148               pizda(1,1))
10149             vv(1)=pizda(1,1)-pizda(2,2)
10150             vv(2)=pizda(1,2)+pizda(2,1)
10151             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
10152              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
10153              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
10154           enddo
10155         enddo
10156       enddo
10157 !      goto 1112
10158 !1111  continue
10159 ! Contribution from graph II
10160       call transpose2(EE(1,1,itk),auxmat(1,1))
10161       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
10162       vv(1)=pizda(1,1)+pizda(2,2)
10163       vv(2)=pizda(2,1)-pizda(1,2)
10164       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
10165        -0.5d0*scalar2(vv(1),Ctobr(1,k))
10166 ! Explicit gradient in virtual-dihedral angles.
10167       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10168        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
10169       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
10170       vv(1)=pizda(1,1)+pizda(2,2)
10171       vv(2)=pizda(2,1)-pizda(1,2)
10172       if (l.eq.j+1) then
10173         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10174          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
10175          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10176       else
10177         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10178          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
10179          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
10180       endif
10181 ! Cartesian gradient
10182       do iii=1,2
10183         do kkk=1,5
10184           do lll=1,3
10185             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
10186               pizda(1,1))
10187             vv(1)=pizda(1,1)+pizda(2,2)
10188             vv(2)=pizda(2,1)-pizda(1,2)
10189             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
10190              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
10191              -0.5d0*scalar2(vv(1),Ctobr(1,k))
10192           enddo
10193         enddo
10194       enddo
10195 !d      goto 1112
10196 !d1111  continue
10197       if (l.eq.j+1) then
10198 !d        goto 1110
10199 ! Parallel orientation
10200 ! Contribution from graph III
10201         call transpose2(EUg(1,1,l),auxmat(1,1))
10202         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10203         vv(1)=pizda(1,1)-pizda(2,2)
10204         vv(2)=pizda(1,2)+pizda(2,1)
10205         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
10206          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10207 ! Explicit gradient in virtual-dihedral angles.
10208         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10209          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
10210          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
10211         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10212         vv(1)=pizda(1,1)-pizda(2,2)
10213         vv(2)=pizda(1,2)+pizda(2,1)
10214         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10215          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
10216          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10217         call transpose2(EUgder(1,1,l),auxmat1(1,1))
10218         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10219         vv(1)=pizda(1,1)-pizda(2,2)
10220         vv(2)=pizda(1,2)+pizda(2,1)
10221         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10222          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
10223          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
10224 ! Cartesian gradient
10225         do iii=1,2
10226           do kkk=1,5
10227             do lll=1,3
10228               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
10229                 pizda(1,1))
10230               vv(1)=pizda(1,1)-pizda(2,2)
10231               vv(2)=pizda(1,2)+pizda(2,1)
10232               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
10233                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
10234                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
10235             enddo
10236           enddo
10237         enddo
10238 !d        goto 1112
10239 ! Contribution from graph IV
10240 !d1110    continue
10241         call transpose2(EE(1,1,itl),auxmat(1,1))
10242         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10243         vv(1)=pizda(1,1)+pizda(2,2)
10244         vv(2)=pizda(2,1)-pizda(1,2)
10245         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
10246          -0.5d0*scalar2(vv(1),Ctobr(1,l))
10247 ! Explicit gradient in virtual-dihedral angles.
10248         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10249          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
10250         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10251         vv(1)=pizda(1,1)+pizda(2,2)
10252         vv(2)=pizda(2,1)-pizda(1,2)
10253         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10254          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
10255          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
10256 ! Cartesian gradient
10257         do iii=1,2
10258           do kkk=1,5
10259             do lll=1,3
10260               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
10261                 pizda(1,1))
10262               vv(1)=pizda(1,1)+pizda(2,2)
10263               vv(2)=pizda(2,1)-pizda(1,2)
10264               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
10265                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
10266                -0.5d0*scalar2(vv(1),Ctobr(1,l))
10267             enddo
10268           enddo
10269         enddo
10270       else
10271 ! Antiparallel orientation
10272 ! Contribution from graph III
10273 !        goto 1110
10274         call transpose2(EUg(1,1,j),auxmat(1,1))
10275         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
10276         vv(1)=pizda(1,1)-pizda(2,2)
10277         vv(2)=pizda(1,2)+pizda(2,1)
10278         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
10279          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10280 ! Explicit gradient in virtual-dihedral angles.
10281         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
10282          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
10283          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
10284         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
10285         vv(1)=pizda(1,1)-pizda(2,2)
10286         vv(2)=pizda(1,2)+pizda(2,1)
10287         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10288          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
10289          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10290         call transpose2(EUgder(1,1,j),auxmat1(1,1))
10291         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
10292         vv(1)=pizda(1,1)-pizda(2,2)
10293         vv(2)=pizda(1,2)+pizda(2,1)
10294         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10295          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
10296          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
10297 ! Cartesian gradient
10298         do iii=1,2
10299           do kkk=1,5
10300             do lll=1,3
10301               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
10302                 pizda(1,1))
10303               vv(1)=pizda(1,1)-pizda(2,2)
10304               vv(2)=pizda(1,2)+pizda(2,1)
10305               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
10306                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
10307                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
10308             enddo
10309           enddo
10310         enddo
10311 !d        goto 1112
10312 ! Contribution from graph IV
10313 1110    continue
10314         call transpose2(EE(1,1,itj),auxmat(1,1))
10315         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
10316         vv(1)=pizda(1,1)+pizda(2,2)
10317         vv(2)=pizda(2,1)-pizda(1,2)
10318         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
10319          -0.5d0*scalar2(vv(1),Ctobr(1,j))
10320 ! Explicit gradient in virtual-dihedral angles.
10321         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
10322          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
10323         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
10324         vv(1)=pizda(1,1)+pizda(2,2)
10325         vv(2)=pizda(2,1)-pizda(1,2)
10326         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
10327          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
10328          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
10329 ! Cartesian gradient
10330         do iii=1,2
10331           do kkk=1,5
10332             do lll=1,3
10333               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
10334                 pizda(1,1))
10335               vv(1)=pizda(1,1)+pizda(2,2)
10336               vv(2)=pizda(2,1)-pizda(1,2)
10337               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
10338                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
10339                -0.5d0*scalar2(vv(1),Ctobr(1,j))
10340             enddo
10341           enddo
10342         enddo
10343       endif
10344 1112  continue
10345       eel5=eello5_1+eello5_2+eello5_3+eello5_4
10346 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
10347 !d        write (2,*) 'ijkl',i,j,k,l
10348 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
10349 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
10350 !d      endif
10351 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
10352 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
10353 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
10354 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
10355       if (j.lt.nres-1) then
10356         j1=j+1
10357         j2=j-1
10358       else
10359         j1=j-1
10360         j2=j-2
10361       endif
10362       if (l.lt.nres-1) then
10363         l1=l+1
10364         l2=l-1
10365       else
10366         l1=l-1
10367         l2=l-2
10368       endif
10369 !d      eij=1.0d0
10370 !d      ekl=1.0d0
10371 !d      ekont=1.0d0
10372 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
10373 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
10374 !        summed up outside the subrouine as for the other subroutines
10375 !        handling long-range interactions. The old code is commented out
10376 !        with "cgrad" to keep track of changes.
10377       do ll=1,3
10378 !grad        ggg1(ll)=eel5*g_contij(ll,1)
10379 !grad        ggg2(ll)=eel5*g_contij(ll,2)
10380         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
10381         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
10382 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
10383 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
10384 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
10385 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
10386 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
10387 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
10388 !     &   gradcorr5ij,
10389 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
10390 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
10391 !grad        ghalf=0.5d0*ggg1(ll)
10392 !d        ghalf=0.0d0
10393         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
10394         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
10395         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
10396         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
10397         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
10398         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
10399 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
10400 !grad        ghalf=0.5d0*ggg2(ll)
10401         ghalf=0.0d0
10402         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
10403         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
10404         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
10405         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
10406         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
10407         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10408       enddo
10409 !d      goto 1112
10410 !grad      do m=i+1,j-1
10411 !grad        do ll=1,3
10412 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10413 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10414 !grad        enddo
10415 !grad      enddo
10416 !grad      do m=k+1,l-1
10417 !grad        do ll=1,3
10418 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10419 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10420 !grad        enddo
10421 !grad      enddo
10422 !1112  continue
10423 !grad      do m=i+2,j2
10424 !grad        do ll=1,3
10425 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10426 !grad        enddo
10427 !grad      enddo
10428 !grad      do m=k+2,l2
10429 !grad        do ll=1,3
10430 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10431 !grad        enddo
10432 !grad      enddo
10433 !d      do iii=1,nres-3
10434 !d        write (2,*) iii,g_corr5_loc(iii)
10435 !d      enddo
10436       eello5=ekont*eel5
10437 !d      write (2,*) 'ekont',ekont
10438 !d      write (iout,*) 'eello5',ekont*eel5
10439       return
10440       end function eello5
10441 !-----------------------------------------------------------------------------
10442       real(kind=8) function eello6(i,j,k,l,jj,kk)
10443 !      implicit real*8 (a-h,o-z)
10444 !      include 'DIMENSIONS'
10445 !      include 'COMMON.IOUNITS'
10446 !      include 'COMMON.CHAIN'
10447 !      include 'COMMON.DERIV'
10448 !      include 'COMMON.INTERACT'
10449 !      include 'COMMON.CONTACTS'
10450 !      include 'COMMON.TORSION'
10451 !      include 'COMMON.VAR'
10452 !      include 'COMMON.GEO'
10453 !      include 'COMMON.FFIELD'
10454       real(kind=8),dimension(3) :: ggg1,ggg2
10455       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
10456                    eello6_6,eel6
10457       real(kind=8) :: gradcorr6ij,gradcorr6kl
10458       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
10459 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10460 !d        eello6=0.0d0
10461 !d        return
10462 !d      endif
10463 !d      write (iout,*)
10464 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10465 !d     &   ' and',k,l
10466       eello6_1=0.0d0
10467       eello6_2=0.0d0
10468       eello6_3=0.0d0
10469       eello6_4=0.0d0
10470       eello6_5=0.0d0
10471       eello6_6=0.0d0
10472 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10473 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10474       do iii=1,2
10475         do kkk=1,5
10476           do lll=1,3
10477             derx(lll,kkk,iii)=0.0d0
10478           enddo
10479         enddo
10480       enddo
10481 !d      eij=facont_hb(jj,i)
10482 !d      ekl=facont_hb(kk,k)
10483 !d      ekont=eij*ekl
10484 !d      eij=1.0d0
10485 !d      ekl=1.0d0
10486 !d      ekont=1.0d0
10487       if (l.eq.j+1) then
10488         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10489         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10490         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10491         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10492         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10493         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10494       else
10495         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10496         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10497         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10498         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10499         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10500           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10501         else
10502           eello6_5=0.0d0
10503         endif
10504         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10505       endif
10506 ! If turn contributions are considered, they will be handled separately.
10507       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10508 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10509 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10510 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10511 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10512 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10513 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10514 !d      goto 1112
10515       if (j.lt.nres-1) then
10516         j1=j+1
10517         j2=j-1
10518       else
10519         j1=j-1
10520         j2=j-2
10521       endif
10522       if (l.lt.nres-1) then
10523         l1=l+1
10524         l2=l-1
10525       else
10526         l1=l-1
10527         l2=l-2
10528       endif
10529       do ll=1,3
10530 !grad        ggg1(ll)=eel6*g_contij(ll,1)
10531 !grad        ggg2(ll)=eel6*g_contij(ll,2)
10532 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10533 !grad        ghalf=0.5d0*ggg1(ll)
10534 !d        ghalf=0.0d0
10535         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10536         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10537         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10538         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10539         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10540         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10541         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10542         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10543 !grad        ghalf=0.5d0*ggg2(ll)
10544 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10545 !d        ghalf=0.0d0
10546         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10547         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10548         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10549         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10550         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10551         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10552       enddo
10553 !d      goto 1112
10554 !grad      do m=i+1,j-1
10555 !grad        do ll=1,3
10556 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10557 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10558 !grad        enddo
10559 !grad      enddo
10560 !grad      do m=k+1,l-1
10561 !grad        do ll=1,3
10562 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10563 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10564 !grad        enddo
10565 !grad      enddo
10566 !grad1112  continue
10567 !grad      do m=i+2,j2
10568 !grad        do ll=1,3
10569 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10570 !grad        enddo
10571 !grad      enddo
10572 !grad      do m=k+2,l2
10573 !grad        do ll=1,3
10574 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10575 !grad        enddo
10576 !grad      enddo
10577 !d      do iii=1,nres-3
10578 !d        write (2,*) iii,g_corr6_loc(iii)
10579 !d      enddo
10580       eello6=ekont*eel6
10581 !d      write (2,*) 'ekont',ekont
10582 !d      write (iout,*) 'eello6',ekont*eel6
10583       return
10584       end function eello6
10585 !-----------------------------------------------------------------------------
10586       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
10587       use comm_kut
10588 !      implicit real*8 (a-h,o-z)
10589 !      include 'DIMENSIONS'
10590 !      include 'COMMON.IOUNITS'
10591 !      include 'COMMON.CHAIN'
10592 !      include 'COMMON.DERIV'
10593 !      include 'COMMON.INTERACT'
10594 !      include 'COMMON.CONTACTS'
10595 !      include 'COMMON.TORSION'
10596 !      include 'COMMON.VAR'
10597 !      include 'COMMON.GEO'
10598       real(kind=8),dimension(2) :: vv,vv1
10599       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
10600       logical :: swap
10601 !el      logical :: lprn
10602 !el      common /kutas/ lprn
10603       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
10604       real(kind=8) :: s1,s2,s3,s4,s5
10605 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10606 !                                                                              C
10607 !      Parallel       Antiparallel                                             C
10608 !                                                                              C
10609 !          o             o                                                     C
10610 !         /l\           /j\                                                    C
10611 !        /   \         /   \                                                   C
10612 !       /| o |         | o |\                                                  C
10613 !     \ j|/k\|  /   \  |/k\|l /                                                C
10614 !      \ /   \ /     \ /   \ /                                                 C
10615 !       o     o       o     o                                                  C
10616 !       i             i                                                        C
10617 !                                                                              C
10618 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10619       itk=itortyp(itype(k,1))
10620       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10621       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10622       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10623       call transpose2(EUgC(1,1,k),auxmat(1,1))
10624       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10625       vv1(1)=pizda1(1,1)-pizda1(2,2)
10626       vv1(2)=pizda1(1,2)+pizda1(2,1)
10627       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10628       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
10629       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
10630       s5=scalar2(vv(1),Dtobr2(1,i))
10631 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10632       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10633       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
10634        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
10635        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
10636        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
10637        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
10638        +scalar2(vv(1),Dtobr2der(1,i)))
10639       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10640       vv1(1)=pizda1(1,1)-pizda1(2,2)
10641       vv1(2)=pizda1(1,2)+pizda1(2,1)
10642       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
10643       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
10644       if (l.eq.j+1) then
10645         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
10646        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10647        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10648        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10649        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10650       else
10651         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
10652        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
10653        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
10654        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
10655        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10656       endif
10657       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10658       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10659       vv1(1)=pizda1(1,1)-pizda1(2,2)
10660       vv1(2)=pizda1(1,2)+pizda1(2,1)
10661       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
10662        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
10663        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
10664        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10665       do iii=1,2
10666         if (swap) then
10667           ind=3-iii
10668         else
10669           ind=iii
10670         endif
10671         do kkk=1,5
10672           do lll=1,3
10673             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10674             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10675             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10676             call transpose2(EUgC(1,1,k),auxmat(1,1))
10677             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10678               pizda1(1,1))
10679             vv1(1)=pizda1(1,1)-pizda1(2,2)
10680             vv1(2)=pizda1(1,2)+pizda1(2,1)
10681             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10682             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
10683              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
10684             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
10685              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
10686             s5=scalar2(vv(1),Dtobr2(1,i))
10687             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10688           enddo
10689         enddo
10690       enddo
10691       return
10692       end function eello6_graph1
10693 !-----------------------------------------------------------------------------
10694       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
10695       use comm_kut
10696 !      implicit real*8 (a-h,o-z)
10697 !      include 'DIMENSIONS'
10698 !      include 'COMMON.IOUNITS'
10699 !      include 'COMMON.CHAIN'
10700 !      include 'COMMON.DERIV'
10701 !      include 'COMMON.INTERACT'
10702 !      include 'COMMON.CONTACTS'
10703 !      include 'COMMON.TORSION'
10704 !      include 'COMMON.VAR'
10705 !      include 'COMMON.GEO'
10706       logical :: swap
10707       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
10708       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
10709 !el      logical :: lprn
10710 !el      common /kutas/ lprn
10711       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
10712       real(kind=8) :: s2,s3,s4
10713 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10714 !                                                                              C
10715 !      Parallel       Antiparallel                                             C
10716 !                                                                              C
10717 !          o             o                                                     C
10718 !     \   /l\           /j\   /                                                C
10719 !      \ /   \         /   \ /                                                 C
10720 !       o| o |         | o |o                                                  C
10721 !     \ j|/k\|      \  |/k\|l                                                  C
10722 !      \ /   \       \ /   \                                                   C
10723 !       o             o                                                        C
10724 !       i             i                                                        C
10725 !                                                                              C
10726 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10727 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10728 ! AL 7/4/01 s1 would occur in the sixth-order moment,
10729 !           but not in a cluster cumulant
10730 #ifdef MOMENT
10731       s1=dip(1,jj,i)*dip(1,kk,k)
10732 #endif
10733       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10734       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10735       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10736       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10737       call transpose2(EUg(1,1,k),auxmat(1,1))
10738       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10739       vv(1)=pizda(1,1)-pizda(2,2)
10740       vv(2)=pizda(1,2)+pizda(2,1)
10741       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10742 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10743 #ifdef MOMENT
10744       eello6_graph2=-(s1+s2+s3+s4)
10745 #else
10746       eello6_graph2=-(s2+s3+s4)
10747 #endif
10748 !      eello6_graph2=-s3
10749 ! Derivatives in gamma(i-1)
10750       if (i.gt.1) then
10751 #ifdef MOMENT
10752         s1=dipderg(1,jj,i)*dip(1,kk,k)
10753 #endif
10754         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10755         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10756         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10757         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10758 #ifdef MOMENT
10759         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10760 #else
10761         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10762 #endif
10763 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10764       endif
10765 ! Derivatives in gamma(k-1)
10766 #ifdef MOMENT
10767       s1=dip(1,jj,i)*dipderg(1,kk,k)
10768 #endif
10769       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10770       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10771       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10772       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10773       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10774       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10775       vv(1)=pizda(1,1)-pizda(2,2)
10776       vv(2)=pizda(1,2)+pizda(2,1)
10777       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10778 #ifdef MOMENT
10779       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10780 #else
10781       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10782 #endif
10783 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10784 ! Derivatives in gamma(j-1) or gamma(l-1)
10785       if (j.gt.1) then
10786 #ifdef MOMENT
10787         s1=dipderg(3,jj,i)*dip(1,kk,k)
10788 #endif
10789         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10790         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10791         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10792         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10793         vv(1)=pizda(1,1)-pizda(2,2)
10794         vv(2)=pizda(1,2)+pizda(2,1)
10795         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10796 #ifdef MOMENT
10797         if (swap) then
10798           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10799         else
10800           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10801         endif
10802 #endif
10803         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10804 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10805       endif
10806 ! Derivatives in gamma(l-1) or gamma(j-1)
10807       if (l.gt.1) then
10808 #ifdef MOMENT
10809         s1=dip(1,jj,i)*dipderg(3,kk,k)
10810 #endif
10811         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10812         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10813         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10814         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10815         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10816         vv(1)=pizda(1,1)-pizda(2,2)
10817         vv(2)=pizda(1,2)+pizda(2,1)
10818         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10819 #ifdef MOMENT
10820         if (swap) then
10821           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10822         else
10823           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10824         endif
10825 #endif
10826         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10827 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10828       endif
10829 ! Cartesian derivatives.
10830       if (lprn) then
10831         write (2,*) 'In eello6_graph2'
10832         do iii=1,2
10833           write (2,*) 'iii=',iii
10834           do kkk=1,5
10835             write (2,*) 'kkk=',kkk
10836             do jjj=1,2
10837               write (2,'(3(2f10.5),5x)') &
10838               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10839             enddo
10840           enddo
10841         enddo
10842       endif
10843       do iii=1,2
10844         do kkk=1,5
10845           do lll=1,3
10846 #ifdef MOMENT
10847             if (iii.eq.1) then
10848               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10849             else
10850               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10851             endif
10852 #endif
10853             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
10854               auxvec(1))
10855             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10856             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
10857               auxvec(1))
10858             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10859             call transpose2(EUg(1,1,k),auxmat(1,1))
10860             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
10861               pizda(1,1))
10862             vv(1)=pizda(1,1)-pizda(2,2)
10863             vv(2)=pizda(1,2)+pizda(2,1)
10864             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10865 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10866 #ifdef MOMENT
10867             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10868 #else
10869             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10870 #endif
10871             if (swap) then
10872               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10873             else
10874               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10875             endif
10876           enddo
10877         enddo
10878       enddo
10879       return
10880       end function eello6_graph2
10881 !-----------------------------------------------------------------------------
10882       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
10883 !      implicit real*8 (a-h,o-z)
10884 !      include 'DIMENSIONS'
10885 !      include 'COMMON.IOUNITS'
10886 !      include 'COMMON.CHAIN'
10887 !      include 'COMMON.DERIV'
10888 !      include 'COMMON.INTERACT'
10889 !      include 'COMMON.CONTACTS'
10890 !      include 'COMMON.TORSION'
10891 !      include 'COMMON.VAR'
10892 !      include 'COMMON.GEO'
10893       real(kind=8),dimension(2) :: vv,auxvec
10894       real(kind=8),dimension(2,2) :: pizda,auxmat
10895       logical :: swap
10896       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
10897       real(kind=8) :: s1,s2,s3,s4
10898 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10899 !                                                                              C
10900 !      Parallel       Antiparallel                                             C
10901 !                                                                              C
10902 !          o             o                                                     C
10903 !         /l\   /   \   /j\                                                    C
10904 !        /   \ /     \ /   \                                                   C
10905 !       /| o |o       o| o |\                                                  C
10906 !       j|/k\|  /      |/k\|l /                                                C
10907 !        /   \ /       /   \ /                                                 C
10908 !       /     o       /     o                                                  C
10909 !       i             i                                                        C
10910 !                                                                              C
10911 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10912 !
10913 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
10914 !           energy moment and not to the cluster cumulant.
10915       iti=itortyp(itype(i,1))
10916       if (j.lt.nres-1) then
10917         itj1=itortyp(itype(j+1,1))
10918       else
10919         itj1=ntortyp+1
10920       endif
10921       itk=itortyp(itype(k,1))
10922       itk1=itortyp(itype(k+1,1))
10923       if (l.lt.nres-1) then
10924         itl1=itortyp(itype(l+1,1))
10925       else
10926         itl1=ntortyp+1
10927       endif
10928 #ifdef MOMENT
10929       s1=dip(4,jj,i)*dip(4,kk,k)
10930 #endif
10931       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
10932       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10933       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
10934       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10935       call transpose2(EE(1,1,itk),auxmat(1,1))
10936       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10937       vv(1)=pizda(1,1)+pizda(2,2)
10938       vv(2)=pizda(2,1)-pizda(1,2)
10939       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10940 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10941 !d     & "sum",-(s2+s3+s4)
10942 #ifdef MOMENT
10943       eello6_graph3=-(s1+s2+s3+s4)
10944 #else
10945       eello6_graph3=-(s2+s3+s4)
10946 #endif
10947 !      eello6_graph3=-s4
10948 ! Derivatives in gamma(k-1)
10949       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
10950       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10951       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10952       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10953 ! Derivatives in gamma(l-1)
10954       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
10955       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10956       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10957       vv(1)=pizda(1,1)+pizda(2,2)
10958       vv(2)=pizda(2,1)-pizda(1,2)
10959       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10960       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10961 ! Cartesian derivatives.
10962       do iii=1,2
10963         do kkk=1,5
10964           do lll=1,3
10965 #ifdef MOMENT
10966             if (iii.eq.1) then
10967               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10968             else
10969               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10970             endif
10971 #endif
10972             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
10973               auxvec(1))
10974             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
10975             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
10976               auxvec(1))
10977             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
10978             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
10979               pizda(1,1))
10980             vv(1)=pizda(1,1)+pizda(2,2)
10981             vv(2)=pizda(2,1)-pizda(1,2)
10982             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10983 #ifdef MOMENT
10984             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10985 #else
10986             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10987 #endif
10988             if (swap) then
10989               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10990             else
10991               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10992             endif
10993 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10994           enddo
10995         enddo
10996       enddo
10997       return
10998       end function eello6_graph3
10999 !-----------------------------------------------------------------------------
11000       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
11001 !      implicit real*8 (a-h,o-z)
11002 !      include 'DIMENSIONS'
11003 !      include 'COMMON.IOUNITS'
11004 !      include 'COMMON.CHAIN'
11005 !      include 'COMMON.DERIV'
11006 !      include 'COMMON.INTERACT'
11007 !      include 'COMMON.CONTACTS'
11008 !      include 'COMMON.TORSION'
11009 !      include 'COMMON.VAR'
11010 !      include 'COMMON.GEO'
11011 !      include 'COMMON.FFIELD'
11012       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
11013       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
11014       logical :: swap
11015       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
11016               iii,kkk,lll
11017       real(kind=8) :: s1,s2,s3,s4
11018 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11019 !                                                                              C
11020 !      Parallel       Antiparallel                                             C
11021 !                                                                              C
11022 !          o             o                                                     C
11023 !         /l\   /   \   /j\                                                    C
11024 !        /   \ /     \ /   \                                                   C
11025 !       /| o |o       o| o |\                                                  C
11026 !     \ j|/k\|      \  |/k\|l                                                  C
11027 !      \ /   \       \ /   \                                                   C
11028 !       o     \       o     \                                                  C
11029 !       i             i                                                        C
11030 !                                                                              C
11031 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
11032 !
11033 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
11034 !           energy moment and not to the cluster cumulant.
11035 !d      write (2,*) 'eello_graph4: wturn6',wturn6
11036       iti=itortyp(itype(i,1))
11037       itj=itortyp(itype(j,1))
11038       if (j.lt.nres-1) then
11039         itj1=itortyp(itype(j+1,1))
11040       else
11041         itj1=ntortyp+1
11042       endif
11043       itk=itortyp(itype(k,1))
11044       if (k.lt.nres-1) then
11045         itk1=itortyp(itype(k+1,1))
11046       else
11047         itk1=ntortyp+1
11048       endif
11049       itl=itortyp(itype(l,1))
11050       if (l.lt.nres-1) then
11051         itl1=itortyp(itype(l+1,1))
11052       else
11053         itl1=ntortyp+1
11054       endif
11055 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
11056 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
11057 !d     & ' itl',itl,' itl1',itl1
11058 #ifdef MOMENT
11059       if (imat.eq.1) then
11060         s1=dip(3,jj,i)*dip(3,kk,k)
11061       else
11062         s1=dip(2,jj,j)*dip(2,kk,l)
11063       endif
11064 #endif
11065       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
11066       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11067       if (j.eq.l+1) then
11068         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
11069         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
11070       else
11071         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
11072         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
11073       endif
11074       call transpose2(EUg(1,1,k),auxmat(1,1))
11075       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
11076       vv(1)=pizda(1,1)-pizda(2,2)
11077       vv(2)=pizda(2,1)+pizda(1,2)
11078       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11079 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
11080 #ifdef MOMENT
11081       eello6_graph4=-(s1+s2+s3+s4)
11082 #else
11083       eello6_graph4=-(s2+s3+s4)
11084 #endif
11085 ! Derivatives in gamma(i-1)
11086       if (i.gt.1) then
11087 #ifdef MOMENT
11088         if (imat.eq.1) then
11089           s1=dipderg(2,jj,i)*dip(3,kk,k)
11090         else
11091           s1=dipderg(4,jj,j)*dip(2,kk,l)
11092         endif
11093 #endif
11094         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
11095         if (j.eq.l+1) then
11096           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
11097           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
11098         else
11099           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
11100           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
11101         endif
11102         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
11103         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11104 !d          write (2,*) 'turn6 derivatives'
11105 #ifdef MOMENT
11106           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
11107 #else
11108           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
11109 #endif
11110         else
11111 #ifdef MOMENT
11112           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
11113 #else
11114           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
11115 #endif
11116         endif
11117       endif
11118 ! Derivatives in gamma(k-1)
11119 #ifdef MOMENT
11120       if (imat.eq.1) then
11121         s1=dip(3,jj,i)*dipderg(2,kk,k)
11122       else
11123         s1=dip(2,jj,j)*dipderg(4,kk,l)
11124       endif
11125 #endif
11126       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
11127       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
11128       if (j.eq.l+1) then
11129         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
11130         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
11131       else
11132         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
11133         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
11134       endif
11135       call transpose2(EUgder(1,1,k),auxmat1(1,1))
11136       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
11137       vv(1)=pizda(1,1)-pizda(2,2)
11138       vv(2)=pizda(2,1)+pizda(1,2)
11139       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11140       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11141 #ifdef MOMENT
11142         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
11143 #else
11144         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
11145 #endif
11146       else
11147 #ifdef MOMENT
11148         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
11149 #else
11150         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
11151 #endif
11152       endif
11153 ! Derivatives in gamma(j-1) or gamma(l-1)
11154       if (l.eq.j+1 .and. l.gt.1) then
11155         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11156         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11157         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11158         vv(1)=pizda(1,1)-pizda(2,2)
11159         vv(2)=pizda(2,1)+pizda(1,2)
11160         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11161         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
11162       else if (j.gt.1) then
11163         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
11164         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11165         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
11166         vv(1)=pizda(1,1)-pizda(2,2)
11167         vv(2)=pizda(2,1)+pizda(1,2)
11168         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11169         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11170           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
11171         else
11172           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
11173         endif
11174       endif
11175 ! Cartesian derivatives.
11176       do iii=1,2
11177         do kkk=1,5
11178           do lll=1,3
11179 #ifdef MOMENT
11180             if (iii.eq.1) then
11181               if (imat.eq.1) then
11182                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
11183               else
11184                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
11185               endif
11186             else
11187               if (imat.eq.1) then
11188                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
11189               else
11190                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
11191               endif
11192             endif
11193 #endif
11194             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
11195               auxvec(1))
11196             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
11197             if (j.eq.l+1) then
11198               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
11199                 b1(1,itj1),auxvec(1))
11200               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
11201             else
11202               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
11203                 b1(1,itl1),auxvec(1))
11204               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
11205             endif
11206             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
11207               pizda(1,1))
11208             vv(1)=pizda(1,1)-pizda(2,2)
11209             vv(2)=pizda(2,1)+pizda(1,2)
11210             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
11211             if (swap) then
11212               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
11213 #ifdef MOMENT
11214                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
11215                    -(s1+s2+s4)
11216 #else
11217                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
11218                    -(s2+s4)
11219 #endif
11220                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
11221               else
11222 #ifdef MOMENT
11223                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
11224 #else
11225                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
11226 #endif
11227                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11228               endif
11229             else
11230 #ifdef MOMENT
11231               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
11232 #else
11233               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
11234 #endif
11235               if (l.eq.j+1) then
11236                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
11237               else
11238                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
11239               endif
11240             endif
11241           enddo
11242         enddo
11243       enddo
11244       return
11245       end function eello6_graph4
11246 !-----------------------------------------------------------------------------
11247       real(kind=8) function eello_turn6(i,jj,kk)
11248 !      implicit real*8 (a-h,o-z)
11249 !      include 'DIMENSIONS'
11250 !      include 'COMMON.IOUNITS'
11251 !      include 'COMMON.CHAIN'
11252 !      include 'COMMON.DERIV'
11253 !      include 'COMMON.INTERACT'
11254 !      include 'COMMON.CONTACTS'
11255 !      include 'COMMON.TORSION'
11256 !      include 'COMMON.VAR'
11257 !      include 'COMMON.GEO'
11258       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
11259       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
11260       real(kind=8),dimension(3) :: ggg1,ggg2
11261       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
11262       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
11263 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
11264 !           the respective energy moment and not to the cluster cumulant.
11265 !el local variables
11266       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
11267       integer :: j1,j2,l1,l2,ll
11268       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
11269       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
11270       s1=0.0d0
11271       s8=0.0d0
11272       s13=0.0d0
11273 !
11274       eello_turn6=0.0d0
11275       j=i+4
11276       k=i+1
11277       l=i+3
11278       iti=itortyp(itype(i,1))
11279       itk=itortyp(itype(k,1))
11280       itk1=itortyp(itype(k+1,1))
11281       itl=itortyp(itype(l,1))
11282       itj=itortyp(itype(j,1))
11283 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
11284 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
11285 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
11286 !d        eello6=0.0d0
11287 !d        return
11288 !d      endif
11289 !d      write (iout,*)
11290 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
11291 !d     &   ' and',k,l
11292 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
11293       do iii=1,2
11294         do kkk=1,5
11295           do lll=1,3
11296             derx_turn(lll,kkk,iii)=0.0d0
11297           enddo
11298         enddo
11299       enddo
11300 !d      eij=1.0d0
11301 !d      ekl=1.0d0
11302 !d      ekont=1.0d0
11303       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
11304 !d      eello6_5=0.0d0
11305 !d      write (2,*) 'eello6_5',eello6_5
11306 #ifdef MOMENT
11307       call transpose2(AEA(1,1,1),auxmat(1,1))
11308       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
11309       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
11310       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
11311 #endif
11312       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
11313       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
11314       s2 = scalar2(b1(1,itk),vtemp1(1))
11315 #ifdef MOMENT
11316       call transpose2(AEA(1,1,2),atemp(1,1))
11317       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
11318       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
11319       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11320 #endif
11321       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
11322       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
11323       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
11324 #ifdef MOMENT
11325       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
11326       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
11327       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
11328       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
11329       ss13 = scalar2(b1(1,itk),vtemp4(1))
11330       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
11331 #endif
11332 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
11333 !      s1=0.0d0
11334 !      s2=0.0d0
11335 !      s8=0.0d0
11336 !      s12=0.0d0
11337 !      s13=0.0d0
11338       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
11339 ! Derivatives in gamma(i+2)
11340       s1d =0.0d0
11341       s8d =0.0d0
11342 #ifdef MOMENT
11343       call transpose2(AEA(1,1,1),auxmatd(1,1))
11344       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11345       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11346       call transpose2(AEAderg(1,1,2),atempd(1,1))
11347       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11348       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11349 #endif
11350       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
11351       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11352       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11353 !      s1d=0.0d0
11354 !      s2d=0.0d0
11355 !      s8d=0.0d0
11356 !      s12d=0.0d0
11357 !      s13d=0.0d0
11358       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
11359 ! Derivatives in gamma(i+3)
11360 #ifdef MOMENT
11361       call transpose2(AEA(1,1,1),auxmatd(1,1))
11362       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11363       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
11364       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
11365 #endif
11366       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
11367       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
11368       s2d = scalar2(b1(1,itk),vtemp1d(1))
11369 #ifdef MOMENT
11370       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
11371       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
11372 #endif
11373       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
11374 #ifdef MOMENT
11375       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
11376       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11377       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11378 #endif
11379 !      s1d=0.0d0
11380 !      s2d=0.0d0
11381 !      s8d=0.0d0
11382 !      s12d=0.0d0
11383 !      s13d=0.0d0
11384 #ifdef MOMENT
11385       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
11386                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11387 #else
11388       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
11389                     -0.5d0*ekont*(s2d+s12d)
11390 #endif
11391 ! Derivatives in gamma(i+4)
11392       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
11393       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11394       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11395 #ifdef MOMENT
11396       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
11397       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
11398       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
11399 #endif
11400 !      s1d=0.0d0
11401 !      s2d=0.0d0
11402 !      s8d=0.0d0
11403 !      s12d=0.0d0
11404 !      s13d=0.0d0
11405 #ifdef MOMENT
11406       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
11407 #else
11408       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
11409 #endif
11410 ! Derivatives in gamma(i+5)
11411 #ifdef MOMENT
11412       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
11413       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11414       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11415 #endif
11416       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
11417       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
11418       s2d = scalar2(b1(1,itk),vtemp1d(1))
11419 #ifdef MOMENT
11420       call transpose2(AEA(1,1,2),atempd(1,1))
11421       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
11422       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
11423 #endif
11424       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
11425       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11426 #ifdef MOMENT
11427       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
11428       ss13d = scalar2(b1(1,itk),vtemp4d(1))
11429       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11430 #endif
11431 !      s1d=0.0d0
11432 !      s2d=0.0d0
11433 !      s8d=0.0d0
11434 !      s12d=0.0d0
11435 !      s13d=0.0d0
11436 #ifdef MOMENT
11437       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
11438                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11439 #else
11440       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
11441                     -0.5d0*ekont*(s2d+s12d)
11442 #endif
11443 ! Cartesian derivatives
11444       do iii=1,2
11445         do kkk=1,5
11446           do lll=1,3
11447 #ifdef MOMENT
11448             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11449             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11450             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11451 #endif
11452             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
11453             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
11454                 vtemp1d(1))
11455             s2d = scalar2(b1(1,itk),vtemp1d(1))
11456 #ifdef MOMENT
11457             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11458             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11459             s8d = -(atempd(1,1)+atempd(2,2))* &
11460                  scalar2(cc(1,1,itl),vtemp2(1))
11461 #endif
11462             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
11463                  auxmatd(1,1))
11464             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11465             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11466 !      s1d=0.0d0
11467 !      s2d=0.0d0
11468 !      s8d=0.0d0
11469 !      s12d=0.0d0
11470 !      s13d=0.0d0
11471 #ifdef MOMENT
11472             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
11473               - 0.5d0*(s1d+s2d)
11474 #else
11475             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
11476               - 0.5d0*s2d
11477 #endif
11478 #ifdef MOMENT
11479             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
11480               - 0.5d0*(s8d+s12d)
11481 #else
11482             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
11483               - 0.5d0*s12d
11484 #endif
11485           enddo
11486         enddo
11487       enddo
11488 #ifdef MOMENT
11489       do kkk=1,5
11490         do lll=1,3
11491           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
11492             achuj_tempd(1,1))
11493           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11494           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11495           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11496           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11497           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
11498             vtemp4d(1))
11499           ss13d = scalar2(b1(1,itk),vtemp4d(1))
11500           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11501           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11502         enddo
11503       enddo
11504 #endif
11505 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11506 !d     &  16*eel_turn6_num
11507 !d      goto 1112
11508       if (j.lt.nres-1) then
11509         j1=j+1
11510         j2=j-1
11511       else
11512         j1=j-1
11513         j2=j-2
11514       endif
11515       if (l.lt.nres-1) then
11516         l1=l+1
11517         l2=l-1
11518       else
11519         l1=l-1
11520         l2=l-2
11521       endif
11522       do ll=1,3
11523 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11524 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11525 !grad        ghalf=0.5d0*ggg1(ll)
11526 !d        ghalf=0.0d0
11527         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11528         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11529         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
11530           +ekont*derx_turn(ll,2,1)
11531         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11532         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
11533           +ekont*derx_turn(ll,4,1)
11534         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11535         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11536         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11537 !grad        ghalf=0.5d0*ggg2(ll)
11538 !d        ghalf=0.0d0
11539         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
11540           +ekont*derx_turn(ll,2,2)
11541         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11542         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
11543           +ekont*derx_turn(ll,4,2)
11544         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11545         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11546         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11547       enddo
11548 !d      goto 1112
11549 !grad      do m=i+1,j-1
11550 !grad        do ll=1,3
11551 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11552 !grad        enddo
11553 !grad      enddo
11554 !grad      do m=k+1,l-1
11555 !grad        do ll=1,3
11556 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11557 !grad        enddo
11558 !grad      enddo
11559 !grad1112  continue
11560 !grad      do m=i+2,j2
11561 !grad        do ll=1,3
11562 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11563 !grad        enddo
11564 !grad      enddo
11565 !grad      do m=k+2,l2
11566 !grad        do ll=1,3
11567 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11568 !grad        enddo
11569 !grad      enddo
11570 !d      do iii=1,nres-3
11571 !d        write (2,*) iii,g_corr6_loc(iii)
11572 !d      enddo
11573       eello_turn6=ekont*eel_turn6
11574 !d      write (2,*) 'ekont',ekont
11575 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
11576       return
11577       end function eello_turn6
11578 !-----------------------------------------------------------------------------
11579       subroutine MATVEC2(A1,V1,V2)
11580 !DIR$ INLINEALWAYS MATVEC2
11581 #ifndef OSF
11582 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11583 #endif
11584 !      implicit real*8 (a-h,o-z)
11585 !      include 'DIMENSIONS'
11586       real(kind=8),dimension(2) :: V1,V2
11587       real(kind=8),dimension(2,2) :: A1
11588       real(kind=8) :: vaux1,vaux2
11589 !      DO 1 I=1,2
11590 !        VI=0.0
11591 !        DO 3 K=1,2
11592 !    3     VI=VI+A1(I,K)*V1(K)
11593 !        Vaux(I)=VI
11594 !    1 CONTINUE
11595
11596       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11597       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11598
11599       v2(1)=vaux1
11600       v2(2)=vaux2
11601       end subroutine MATVEC2
11602 !-----------------------------------------------------------------------------
11603       subroutine MATMAT2(A1,A2,A3)
11604 #ifndef OSF
11605 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11606 #endif
11607 !      implicit real*8 (a-h,o-z)
11608 !      include 'DIMENSIONS'
11609       real(kind=8),dimension(2,2) :: A1,A2,A3
11610       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
11611 !      DIMENSION AI3(2,2)
11612 !        DO  J=1,2
11613 !          A3IJ=0.0
11614 !          DO K=1,2
11615 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11616 !          enddo
11617 !          A3(I,J)=A3IJ
11618 !       enddo
11619 !      enddo
11620
11621       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11622       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11623       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11624       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11625
11626       A3(1,1)=AI3_11
11627       A3(2,1)=AI3_21
11628       A3(1,2)=AI3_12
11629       A3(2,2)=AI3_22
11630       end subroutine MATMAT2
11631 !-----------------------------------------------------------------------------
11632       real(kind=8) function scalar2(u,v)
11633 !DIR$ INLINEALWAYS scalar2
11634       implicit none
11635       real(kind=8),dimension(2) :: u,v
11636       real(kind=8) :: sc
11637       integer :: i
11638       scalar2=u(1)*v(1)+u(2)*v(2)
11639       return
11640       end function scalar2
11641 !-----------------------------------------------------------------------------
11642       subroutine transpose2(a,at)
11643 !DIR$ INLINEALWAYS transpose2
11644 #ifndef OSF
11645 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
11646 #endif
11647       implicit none
11648       real(kind=8),dimension(2,2) :: a,at
11649       at(1,1)=a(1,1)
11650       at(1,2)=a(2,1)
11651       at(2,1)=a(1,2)
11652       at(2,2)=a(2,2)
11653       return
11654       end subroutine transpose2
11655 !-----------------------------------------------------------------------------
11656       subroutine transpose(n,a,at)
11657       implicit none
11658       integer :: n,i,j
11659       real(kind=8),dimension(n,n) :: a,at
11660       do i=1,n
11661         do j=1,n
11662           at(j,i)=a(i,j)
11663         enddo
11664       enddo
11665       return
11666       end subroutine transpose
11667 !-----------------------------------------------------------------------------
11668       subroutine prodmat3(a1,a2,kk,transp,prod)
11669 !DIR$ INLINEALWAYS prodmat3
11670 #ifndef OSF
11671 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
11672 #endif
11673       implicit none
11674       integer :: i,j
11675       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
11676       logical :: transp
11677 !rc      double precision auxmat(2,2),prod_(2,2)
11678
11679       if (transp) then
11680 !rc        call transpose2(kk(1,1),auxmat(1,1))
11681 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11682 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11683
11684            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
11685        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11686            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
11687        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11688            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
11689        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11690            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
11691        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11692
11693       else
11694 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11695 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11696
11697            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
11698         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11699            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
11700         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11701            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
11702         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11703            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
11704         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11705
11706       endif
11707 !      call transpose2(a2(1,1),a2t(1,1))
11708
11709 !rc      print *,transp
11710 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
11711 !rc      print *,((prod(i,j),i=1,2),j=1,2)
11712
11713       return
11714       end subroutine prodmat3
11715 !-----------------------------------------------------------------------------
11716 ! energy_p_new_barrier.F
11717 !-----------------------------------------------------------------------------
11718       subroutine sum_gradient
11719 !      implicit real*8 (a-h,o-z)
11720       use io_base, only: pdbout
11721 !      include 'DIMENSIONS'
11722 #ifndef ISNAN
11723       external proc_proc
11724 #ifdef WINPGI
11725 !MS$ATTRIBUTES C ::  proc_proc
11726 #endif
11727 #endif
11728 #ifdef MPI
11729       include 'mpif.h'
11730 #endif
11731       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
11732                    gloc_scbuf !(3,maxres)
11733
11734       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
11735 !#endif
11736 !el local variables
11737       integer :: i,j,k,ierror,ierr
11738       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
11739                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
11740                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
11741                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
11742                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
11743                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
11744                    gsccorr_max,gsccorrx_max,time00
11745
11746 !      include 'COMMON.SETUP'
11747 !      include 'COMMON.IOUNITS'
11748 !      include 'COMMON.FFIELD'
11749 !      include 'COMMON.DERIV'
11750 !      include 'COMMON.INTERACT'
11751 !      include 'COMMON.SBRIDGE'
11752 !      include 'COMMON.CHAIN'
11753 !      include 'COMMON.VAR'
11754 !      include 'COMMON.CONTROL'
11755 !      include 'COMMON.TIME1'
11756 !      include 'COMMON.MAXGRAD'
11757 !      include 'COMMON.SCCOR'
11758 #ifdef TIMING
11759       time01=MPI_Wtime()
11760 #endif
11761 !#define DEBUG
11762 #ifdef DEBUG
11763       write (iout,*) "sum_gradient gvdwc, gvdwx"
11764       do i=1,nres
11765         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11766          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
11767       enddo
11768       call flush(iout)
11769 #endif
11770 #ifdef MPI
11771         gradbufc=0.0d0
11772         gradbufx=0.0d0
11773         gradbufc_sum=0.0d0
11774         gloc_scbuf=0.0d0
11775         glocbuf=0.0d0
11776 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
11777         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
11778           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
11779 #endif
11780 !
11781 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
11782 !            in virtual-bond-vector coordinates
11783 !
11784 #ifdef DEBUG
11785 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
11786 !      do i=1,nres-1
11787 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
11788 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
11789 !      enddo
11790 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
11791 !      do i=1,nres-1
11792 !        write (iout,'(i5,3f10.5,2x,f10.5)')
11793 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
11794 !      enddo
11795 !      write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
11796 !      do i=1,nres
11797 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11798 !         i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
11799 !         (gvdwc_scpp(j,i),j=1,3)
11800 !      enddo
11801 !      write (iout,*) "gelc_long gvdwpp gel_loc_long"
11802 !      do i=1,nres
11803 !        write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
11804 !         i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
11805 !         (gelc_loc_long(j,i),j=1,3)
11806 !      enddo
11807       call flush(iout)
11808 #endif
11809 #ifdef SPLITELE
11810       do i=0,nct
11811         do j=1,3
11812           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11813                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11814                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
11815                       wel_loc*gel_loc_long(j,i)+ &
11816                       wcorr*gradcorr_long(j,i)+ &
11817                       wcorr5*gradcorr5_long(j,i)+ &
11818                       wcorr6*gradcorr6_long(j,i)+ &
11819                       wturn6*gcorr6_turn_long(j,i)+ &
11820                       wstrain*ghpbc(j,i) &
11821                      +wliptran*gliptranc(j,i) &
11822                      +gradafm(j,i) &
11823                      +welec*gshieldc(j,i) &
11824                      +wcorr*gshieldc_ec(j,i) &
11825                      +wturn3*gshieldc_t3(j,i)&
11826                      +wturn4*gshieldc_t4(j,i)&
11827                      +wel_loc*gshieldc_ll(j,i)&
11828                      +wtube*gg_tube(j,i) &
11829                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11830                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11831                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11832                      wcorr_nucl*gradcorr_nucl(j,i)&
11833                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
11834                      wcatprot* gradpepcat(j,i)+ &
11835                      wcatcat*gradcatcat(j,i)+   &
11836                      wscbase*gvdwc_scbase(j,i)+ &
11837                      wpepbase*gvdwc_pepbase(j,i)+&
11838                      wscpho*gvdwc_scpho(j,i)+   &
11839                      wpeppho*gvdwc_peppho(j,i)+wcatnucl*gradnuclcat(j,i)
11840
11841
11842
11843
11844
11845         enddo
11846       enddo
11847 #else
11848       do i=0,nct
11849         do j=1,3
11850           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
11851                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
11852                       welec*gelc_long(j,i)+ &
11853                       wbond*gradb(j,i)+ &
11854                       wel_loc*gel_loc_long(j,i)+ &
11855                       wcorr*gradcorr_long(j,i)+ &
11856                       wcorr5*gradcorr5_long(j,i)+ &
11857                       wcorr6*gradcorr6_long(j,i)+ &
11858                       wturn6*gcorr6_turn_long(j,i)+ &
11859                       wstrain*ghpbc(j,i) &
11860                      +wliptran*gliptranc(j,i) &
11861                      +gradafm(j,i) &
11862                      +welec*gshieldc(j,i)&
11863                      +wcorr*gshieldc_ec(j,i) &
11864                      +wturn4*gshieldc_t4(j,i) &
11865                      +wel_loc*gshieldc_ll(j,i)&
11866                      +wtube*gg_tube(j,i) &
11867                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
11868                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
11869                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
11870                      wcorr_nucl*gradcorr_nucl(j,i) &
11871                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
11872                      wcatprot* gradpepcat(j,i)+ &
11873                      wcatcat*gradcatcat(j,i)+   &
11874                      wscbase*gvdwc_scbase(j,i)+ &
11875                      wpepbase*gvdwc_pepbase(j,i)+&
11876                      wscpho*gvdwc_scpho(j,i)+&
11877                      wpeppho*gvdwc_peppho(j,i)+wcatnucl*gradnuclcat(j,i)
11878
11879
11880         enddo
11881       enddo
11882 #endif
11883 #ifdef MPI
11884       if (nfgtasks.gt.1) then
11885       time00=MPI_Wtime()
11886 #ifdef DEBUG
11887       write (iout,*) "gradbufc before allreduce"
11888       do i=1,nres
11889         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11890       enddo
11891       call flush(iout)
11892 #endif
11893       do i=0,nres
11894         do j=1,3
11895           gradbufc_sum(j,i)=gradbufc(j,i)
11896         enddo
11897       enddo
11898 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
11899 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
11900 !      time_reduce=time_reduce+MPI_Wtime()-time00
11901 #ifdef DEBUG
11902 !      write (iout,*) "gradbufc_sum after allreduce"
11903 !      do i=1,nres
11904 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
11905 !      enddo
11906 !      call flush(iout)
11907 #endif
11908 #ifdef TIMING
11909 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
11910 #endif
11911       do i=0,nres
11912         do k=1,3
11913           gradbufc(k,i)=0.0d0
11914         enddo
11915       enddo
11916 #ifdef DEBUG
11917       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
11918       write (iout,*) (i," jgrad_start",jgrad_start(i),&
11919                         " jgrad_end  ",jgrad_end(i),&
11920                         i=igrad_start,igrad_end)
11921 #endif
11922 !
11923 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
11924 ! do not parallelize this part.
11925 !
11926 !      do i=igrad_start,igrad_end
11927 !        do j=jgrad_start(i),jgrad_end(i)
11928 !          do k=1,3
11929 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
11930 !          enddo
11931 !        enddo
11932 !      enddo
11933       do j=1,3
11934         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11935       enddo
11936       do i=nres-2,-1,-1
11937         do j=1,3
11938           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11939         enddo
11940       enddo
11941 #ifdef DEBUG
11942       write (iout,*) "gradbufc after summing"
11943       do i=1,nres
11944         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11945       enddo
11946       call flush(iout)
11947 #endif
11948       else
11949 #endif
11950 !el#define DEBUG
11951 #ifdef DEBUG
11952       write (iout,*) "gradbufc"
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 !el#undef DEBUG
11959       do i=-1,nres
11960         do j=1,3
11961           gradbufc_sum(j,i)=gradbufc(j,i)
11962           gradbufc(j,i)=0.0d0
11963         enddo
11964       enddo
11965       do j=1,3
11966         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
11967       enddo
11968       do i=nres-2,-1,-1
11969         do j=1,3
11970           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
11971         enddo
11972       enddo
11973 !      do i=nnt,nres-1
11974 !        do k=1,3
11975 !          gradbufc(k,i)=0.0d0
11976 !        enddo
11977 !        do j=i+1,nres
11978 !          do k=1,3
11979 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
11980 !          enddo
11981 !        enddo
11982 !      enddo
11983 !el#define DEBUG
11984 #ifdef DEBUG
11985       write (iout,*) "gradbufc after summing"
11986       do i=1,nres
11987         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
11988       enddo
11989       call flush(iout)
11990 #endif
11991 !el#undef DEBUG
11992 #ifdef MPI
11993       endif
11994 #endif
11995       do k=1,3
11996         gradbufc(k,nres)=0.0d0
11997       enddo
11998 !el----------------
11999 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
12000 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
12001 !el-----------------
12002       do i=-1,nct
12003         do j=1,3
12004 #ifdef SPLITELE
12005           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
12006                       wel_loc*gel_loc(j,i)+ &
12007                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
12008                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
12009                       wel_loc*gel_loc_long(j,i)+ &
12010                       wcorr*gradcorr_long(j,i)+ &
12011                       wcorr5*gradcorr5_long(j,i)+ &
12012                       wcorr6*gradcorr6_long(j,i)+ &
12013                       wturn6*gcorr6_turn_long(j,i))+ &
12014                       wbond*gradb(j,i)+ &
12015                       wcorr*gradcorr(j,i)+ &
12016                       wturn3*gcorr3_turn(j,i)+ &
12017                       wturn4*gcorr4_turn(j,i)+ &
12018                       wcorr5*gradcorr5(j,i)+ &
12019                       wcorr6*gradcorr6(j,i)+ &
12020                       wturn6*gcorr6_turn(j,i)+ &
12021                       wsccor*gsccorc(j,i) &
12022                      +wscloc*gscloc(j,i)  &
12023                      +wliptran*gliptranc(j,i) &
12024                      +gradafm(j,i) &
12025                      +welec*gshieldc(j,i) &
12026                      +welec*gshieldc_loc(j,i) &
12027                      +wcorr*gshieldc_ec(j,i) &
12028                      +wcorr*gshieldc_loc_ec(j,i) &
12029                      +wturn3*gshieldc_t3(j,i) &
12030                      +wturn3*gshieldc_loc_t3(j,i) &
12031                      +wturn4*gshieldc_t4(j,i) &
12032                      +wturn4*gshieldc_loc_t4(j,i) &
12033                      +wel_loc*gshieldc_ll(j,i) &
12034                      +wel_loc*gshieldc_loc_ll(j,i) &
12035                      +wtube*gg_tube(j,i) &
12036                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
12037                      +wvdwpsb*gvdwpsb1(j,i))&
12038                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
12039 !                      if (i.eq.21) then
12040 !                      print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),&
12041 !                      wturn4*gshieldc_t4(j,i), &
12042 !                     wturn4*gshieldc_loc_t4(j,i)
12043 !                       endif
12044 !                 if ((i.le.2).and.(i.ge.1))
12045 !                       print *,gradc(j,i,icg),&
12046 !                      gradbufc(j,i),welec*gelc(j,i), &
12047 !                      wel_loc*gel_loc(j,i), &
12048 !                      wscp*gvdwc_scpp(j,i), &
12049 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
12050 !                      wel_loc*gel_loc_long(j,i), &
12051 !                      wcorr*gradcorr_long(j,i), &
12052 !                      wcorr5*gradcorr5_long(j,i), &
12053 !                      wcorr6*gradcorr6_long(j,i), &
12054 !                      wturn6*gcorr6_turn_long(j,i), &
12055 !                      wbond*gradb(j,i), &
12056 !                      wcorr*gradcorr(j,i), &
12057 !                      wturn3*gcorr3_turn(j,i), &
12058 !                      wturn4*gcorr4_turn(j,i), &
12059 !                      wcorr5*gradcorr5(j,i), &
12060 !                      wcorr6*gradcorr6(j,i), &
12061 !                      wturn6*gcorr6_turn(j,i), &
12062 !                      wsccor*gsccorc(j,i) &
12063 !                     ,wscloc*gscloc(j,i)  &
12064 !                     ,wliptran*gliptranc(j,i) &
12065 !                    ,gradafm(j,i) &
12066 !                     ,welec*gshieldc(j,i) &
12067 !                     ,welec*gshieldc_loc(j,i) &
12068 !                     ,wcorr*gshieldc_ec(j,i) &
12069 !                     ,wcorr*gshieldc_loc_ec(j,i) &
12070 !                     ,wturn3*gshieldc_t3(j,i) &
12071 !                     ,wturn3*gshieldc_loc_t3(j,i) &
12072 !                     ,wturn4*gshieldc_t4(j,i) &
12073 !                     ,wturn4*gshieldc_loc_t4(j,i) &
12074 !                     ,wel_loc*gshieldc_ll(j,i) &
12075 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
12076 !                     ,wtube*gg_tube(j,i) &
12077 !                     ,wbond_nucl*gradb_nucl(j,i) &
12078 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
12079 !                     wvdwpsb*gvdwpsb1(j,i)&
12080 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
12081 !
12082
12083 #else
12084           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
12085                       wel_loc*gel_loc(j,i)+ &
12086                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
12087                       welec*gelc_long(j,i)+ &
12088                       wel_loc*gel_loc_long(j,i)+ &
12089 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
12090                       wcorr5*gradcorr5_long(j,i)+ &
12091                       wcorr6*gradcorr6_long(j,i)+ &
12092                       wturn6*gcorr6_turn_long(j,i))+ &
12093                       wbond*gradb(j,i)+ &
12094                       wcorr*gradcorr(j,i)+ &
12095                       wturn3*gcorr3_turn(j,i)+ &
12096                       wturn4*gcorr4_turn(j,i)+ &
12097                       wcorr5*gradcorr5(j,i)+ &
12098                       wcorr6*gradcorr6(j,i)+ &
12099                       wturn6*gcorr6_turn(j,i)+ &
12100                       wsccor*gsccorc(j,i) &
12101                      +wscloc*gscloc(j,i) &
12102                      +gradafm(j,i) &
12103                      +wliptran*gliptranc(j,i) &
12104                      +welec*gshieldc(j,i) &
12105                      +welec*gshieldc_loc(j,i) &
12106                      +wcorr*gshieldc_ec(j,i) &
12107                      +wcorr*gshieldc_loc_ec(j,i) &
12108                      +wturn3*gshieldc_t3(j,i) &
12109                      +wturn3*gshieldc_loc_t3(j,i) &
12110                      +wturn4*gshieldc_t4(j,i) &
12111                      +wturn4*gshieldc_loc_t4(j,i) &
12112                      +wel_loc*gshieldc_ll(j,i) &
12113                      +wel_loc*gshieldc_loc_ll(j,i) &
12114                      +wtube*gg_tube(j,i) &
12115                      +wbond_nucl*gradb_nucl(j,i) &
12116                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
12117                      +wvdwpsb*gvdwpsb1(j,i))&
12118                      +wsbloc*gsbloc(j,i)+wcatnucl*gradnuclcat(j,i)
12119
12120
12121
12122
12123 #endif
12124           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
12125                         wbond*gradbx(j,i)+ &
12126                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
12127                         wsccor*gsccorx(j,i) &
12128                        +wscloc*gsclocx(j,i) &
12129                        +wliptran*gliptranx(j,i) &
12130                        +welec*gshieldx(j,i)     &
12131                        +wcorr*gshieldx_ec(j,i)  &
12132                        +wturn3*gshieldx_t3(j,i) &
12133                        +wturn4*gshieldx_t4(j,i) &
12134                        +wel_loc*gshieldx_ll(j,i)&
12135                        +wtube*gg_tube_sc(j,i)   &
12136                        +wbond_nucl*gradbx_nucl(j,i) &
12137                        +wvdwsb*gvdwsbx(j,i) &
12138                        +welsb*gelsbx(j,i) &
12139                        +wcorr_nucl*gradxorr_nucl(j,i)&
12140                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
12141                        +wsbloc*gsblocx(j,i) &
12142                        +wcatprot* gradpepcatx(j,i)&
12143                        +wscbase*gvdwx_scbase(j,i) &
12144                        +wpepbase*gvdwx_pepbase(j,i)&
12145                        +wscpho*gvdwx_scpho(j,i)+wcatnucl*gradnuclcatx(j,i)
12146 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
12147
12148         enddo
12149       enddo
12150 !      write(iout,*), "const_homol",constr_homology
12151       if (constr_homology.gt.0) then
12152         do i=1,nct
12153           do j=1,3
12154             gradc(j,i,icg)=gradc(j,i,icg)+duscdiff(j,i)
12155 !            write(iout,*) "duscdiff",duscdiff(j,i)
12156             gradx(j,i,icg)=gradx(j,i,icg)+duscdiffx(j,i)
12157           enddo
12158         enddo
12159       endif
12160 !#define DEBUG
12161 #ifdef DEBUG
12162       write (iout,*) "gloc before adding corr"
12163       do i=1,4*nres
12164         write (iout,*) i,gloc(i,icg)
12165       enddo
12166 #endif
12167       do i=1,nres-3
12168         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
12169          +wcorr5*g_corr5_loc(i) &
12170          +wcorr6*g_corr6_loc(i) &
12171          +wturn4*gel_loc_turn4(i) &
12172          +wturn3*gel_loc_turn3(i) &
12173          +wturn6*gel_loc_turn6(i) &
12174          +wel_loc*gel_loc_loc(i)
12175       enddo
12176 #ifdef DEBUG
12177       write (iout,*) "gloc after adding corr"
12178       do i=1,4*nres
12179         write (iout,*) i,gloc(i,icg)
12180       enddo
12181 #endif
12182 !#undef DEBUG
12183 #ifdef MPI
12184       if (nfgtasks.gt.1) then
12185         do j=1,3
12186           do i=0,nres
12187             gradbufc(j,i)=gradc(j,i,icg)
12188             gradbufx(j,i)=gradx(j,i,icg)
12189           enddo
12190         enddo
12191         do i=1,4*nres
12192           glocbuf(i)=gloc(i,icg)
12193         enddo
12194 !#define DEBUG
12195 #ifdef DEBUG
12196       write (iout,*) "gloc_sc before reduce"
12197       do i=1,nres
12198        do j=1,1
12199         write (iout,*) i,j,gloc_sc(j,i,icg)
12200        enddo
12201       enddo
12202 #endif
12203 !#undef DEBUG
12204         do i=0,nres
12205          do j=1,3
12206           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
12207          enddo
12208         enddo
12209         time00=MPI_Wtime()
12210         call MPI_Barrier(FG_COMM,IERR)
12211         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
12212         time00=MPI_Wtime()
12213         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
12214           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12215         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
12216           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12217         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
12218           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12219         time_reduce=time_reduce+MPI_Wtime()-time00
12220         call MPI_Reduce(gloc_scbuf(1,0),gloc_sc(1,0,icg),3*nres+3,&
12221           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12222         time_reduce=time_reduce+MPI_Wtime()-time00
12223 !#define DEBUG
12224 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
12225 #ifdef DEBUG
12226       write (iout,*) "gloc_sc after reduce"
12227       do i=0,nres
12228        do j=1,1
12229         write (iout,*) i,j,gloc_sc(j,i,icg)
12230        enddo
12231       enddo
12232 #endif
12233 !#undef DEBUG
12234 #ifdef DEBUG
12235       write (iout,*) "gloc after reduce"
12236       do i=1,4*nres
12237         write (iout,*) i,gloc(i,icg)
12238       enddo
12239 #endif
12240       endif
12241 #endif
12242       if (gnorm_check) then
12243 !
12244 ! Compute the maximum elements of the gradient
12245 !
12246       gvdwc_max=0.0d0
12247       gvdwc_scp_max=0.0d0
12248       gelc_max=0.0d0
12249       gvdwpp_max=0.0d0
12250       gradb_max=0.0d0
12251       ghpbc_max=0.0d0
12252       gradcorr_max=0.0d0
12253       gel_loc_max=0.0d0
12254       gcorr3_turn_max=0.0d0
12255       gcorr4_turn_max=0.0d0
12256       gradcorr5_max=0.0d0
12257       gradcorr6_max=0.0d0
12258       gcorr6_turn_max=0.0d0
12259       gsccorc_max=0.0d0
12260       gscloc_max=0.0d0
12261       gvdwx_max=0.0d0
12262       gradx_scp_max=0.0d0
12263       ghpbx_max=0.0d0
12264       gradxorr_max=0.0d0
12265       gsccorx_max=0.0d0
12266       gsclocx_max=0.0d0
12267       do i=1,nct
12268         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
12269         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
12270         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
12271         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
12272          gvdwc_scp_max=gvdwc_scp_norm
12273         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
12274         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
12275         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
12276         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
12277         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
12278         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
12279         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
12280         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
12281         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
12282         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
12283         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
12284         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
12285         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
12286           gcorr3_turn(1,i)))
12287         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
12288           gcorr3_turn_max=gcorr3_turn_norm
12289         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
12290           gcorr4_turn(1,i)))
12291         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
12292           gcorr4_turn_max=gcorr4_turn_norm
12293         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
12294         if (gradcorr5_norm.gt.gradcorr5_max) &
12295           gradcorr5_max=gradcorr5_norm
12296         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
12297         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
12298         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
12299           gcorr6_turn(1,i)))
12300         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
12301           gcorr6_turn_max=gcorr6_turn_norm
12302         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
12303         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
12304         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
12305         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
12306         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
12307         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
12308         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
12309         if (gradx_scp_norm.gt.gradx_scp_max) &
12310           gradx_scp_max=gradx_scp_norm
12311         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
12312         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
12313         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
12314         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
12315         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
12316         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
12317         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
12318         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
12319       enddo
12320       if (gradout) then
12321 #ifdef AIX
12322         open(istat,file=statname,position="append")
12323 #else
12324         open(istat,file=statname,access="append")
12325 #endif
12326         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
12327            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
12328            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
12329            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
12330            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
12331            gsccorx_max,gsclocx_max
12332         close(istat)
12333         if (gvdwc_max.gt.1.0d4) then
12334           write (iout,*) "gvdwc gvdwx gradb gradbx"
12335           do i=nnt,nct
12336             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
12337               gradb(j,i),gradbx(j,i),j=1,3)
12338           enddo
12339           call pdbout(0.0d0,'cipiszcze',iout)
12340           call flush(iout)
12341         endif
12342       endif
12343       endif
12344 !#define DEBUG
12345 #ifdef DEBUG
12346       write (iout,*) "gradc gradx gloc"
12347       do i=1,nres
12348         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
12349          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
12350       enddo
12351 #endif
12352 !#undef DEBUG
12353 #ifdef TIMING
12354       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
12355 #endif
12356       return
12357       end subroutine sum_gradient
12358 !-----------------------------------------------------------------------------
12359       subroutine sc_grad
12360 !      implicit real*8 (a-h,o-z)
12361       use calc_data
12362 !      include 'DIMENSIONS'
12363 !      include 'COMMON.CHAIN'
12364 !      include 'COMMON.DERIV'
12365 !      include 'COMMON.CALC'
12366 !      include 'COMMON.IOUNITS'
12367       real(kind=8), dimension(3) :: dcosom1,dcosom2
12368 !      print *,"wchodze"
12369       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
12370           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
12371       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
12372           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
12373
12374       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
12375            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
12376            +dCAVdOM12+ dGCLdOM12
12377 ! diagnostics only
12378 !      eom1=0.0d0
12379 !      eom2=0.0d0
12380 !      eom12=evdwij*eps1_om12
12381 ! end diagnostics
12382 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
12383 !       " sigder",sigder
12384 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
12385 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
12386 !C      print *,sss_ele_cut,'in sc_grad'
12387       do k=1,3
12388         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
12389         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
12390       enddo
12391       do k=1,3
12392         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
12393 !C      print *,'gg',k,gg(k)
12394        enddo
12395 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
12396 !      write (iout,*) "gg",(gg(k),k=1,3)
12397       do k=1,3
12398         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
12399                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
12400                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
12401                   *sss_ele_cut
12402
12403         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
12404                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
12405                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
12406                   *sss_ele_cut
12407
12408 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
12409 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
12410 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
12411 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
12412       enddo
12413 !
12414 ! Calculate the components of the gradient in DC and X
12415 !
12416 !grad      do k=i,j-1
12417 !grad        do l=1,3
12418 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
12419 !grad        enddo
12420 !grad      enddo
12421       do l=1,3
12422         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
12423         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
12424       enddo
12425       return
12426       end subroutine sc_grad
12427
12428       subroutine sc_grad_cat
12429       use calc_data
12430       real(kind=8), dimension(3) :: dcosom1,dcosom2
12431       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
12432           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
12433       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
12434           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
12435
12436       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
12437            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
12438            +dCAVdOM12+ dGCLdOM12
12439 ! diagnostics only
12440 !      eom1=0.0d0
12441 !      eom2=0.0d0
12442 !      eom12=evdwij*eps1_om12
12443 ! end diagnostics
12444
12445       do k=1,3
12446         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
12447         dcosom2(k)=rij*(dc_norm(k,j)-om2*erij(k))
12448       enddo
12449       do k=1,3
12450         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))
12451 !      print *,'gg',k,gg(k)
12452        enddo
12453 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
12454 !      write (iout,*) "gg",(gg(k),k=1,3)
12455       do k=1,3
12456         gradpepcatx(k,i)=gradpepcatx(k,i)-gg(k) &
12457                   +(eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
12458                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
12459
12460 !        gradpepcatx(k,j)=gradpepcatx(k,j)+gg(k) &
12461 !                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)) &
12462 !                  +eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv
12463
12464 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
12465 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
12466 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
12467 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
12468       enddo
12469 !
12470 ! Calculate the components of the gradient in DC and X
12471 !
12472       do l=1,3
12473         gradpepcat(l,i)=gradpepcat(l,i)-gg(l)
12474         gradpepcat(l,j)=gradpepcat(l,j)+gg(l)
12475       enddo
12476       end subroutine sc_grad_cat
12477
12478       subroutine sc_grad_cat_pep
12479       use calc_data
12480       real(kind=8), dimension(3) :: dcosom1,dcosom2
12481       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
12482           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
12483       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
12484           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
12485
12486       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
12487            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
12488            +dCAVdOM12+ dGCLdOM12
12489 ! diagnostics only
12490 !      eom1=0.0d0
12491 !      eom2=0.0d0
12492 !      eom12=evdwij*eps1_om12
12493 ! end diagnostics
12494
12495       do k=1,3
12496         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
12497         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
12498         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
12499         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
12500                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
12501                  *dsci_inv*2.0 &
12502                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
12503         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
12504                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
12505                  *dsci_inv*2.0 &
12506                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
12507         gradpepcat(k,j)=gradpepcat(k,j)+gg(k)
12508       enddo
12509       end subroutine sc_grad_cat_pep
12510
12511 #ifdef CRYST_THETA
12512 !-----------------------------------------------------------------------------
12513       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
12514
12515       use comm_calcthet
12516 !      implicit real*8 (a-h,o-z)
12517 !      include 'DIMENSIONS'
12518 !      include 'COMMON.LOCAL'
12519 !      include 'COMMON.IOUNITS'
12520 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
12521 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
12522 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
12523       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
12524       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
12525 !el      integer :: it
12526 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
12527 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
12528 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
12529 !el local variables
12530
12531       delthec=thetai-thet_pred_mean
12532       delthe0=thetai-theta0i
12533 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
12534       t3 = thetai-thet_pred_mean
12535       t6 = t3**2
12536       t9 = term1
12537       t12 = t3*sigcsq
12538       t14 = t12+t6*sigsqtc
12539       t16 = 1.0d0
12540       t21 = thetai-theta0i
12541       t23 = t21**2
12542       t26 = term2
12543       t27 = t21*t26
12544       t32 = termexp
12545       t40 = t32**2
12546       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
12547        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
12548        *(-t12*t9-ak*sig0inv*t27)
12549       return
12550       end subroutine mixder
12551 #endif
12552 !-----------------------------------------------------------------------------
12553 ! cartder.F
12554 !-----------------------------------------------------------------------------
12555       subroutine cartder
12556 !-----------------------------------------------------------------------------
12557 ! This subroutine calculates the derivatives of the consecutive virtual
12558 ! bond vectors and the SC vectors in the virtual-bond angles theta and
12559 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
12560 ! in the angles alpha and omega, describing the location of a side chain
12561 ! in its local coordinate system.
12562 !
12563 ! The derivatives are stored in the following arrays:
12564 !
12565 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
12566 ! The structure is as follows:
12567 !
12568 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
12569 ! 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)
12570 !         . . . . . . . . . . . .  . . . . . .
12571 ! 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)
12572 !                          .
12573 !                          .
12574 !                          .
12575 ! 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)
12576 !
12577 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
12578 ! The structure is same as above.
12579 !
12580 ! DCDS - the derivatives of the side chain vectors in the local spherical
12581 ! andgles alph and omega:
12582 !
12583 ! 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)
12584 ! 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)
12585 !                          .
12586 !                          .
12587 !                          .
12588 ! 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)
12589 !
12590 ! Version of March '95, based on an early version of November '91.
12591 !
12592 !**********************************************************************
12593 !      implicit real*8 (a-h,o-z)
12594 !      include 'DIMENSIONS'
12595 !      include 'COMMON.VAR'
12596 !      include 'COMMON.CHAIN'
12597 !      include 'COMMON.DERIV'
12598 !      include 'COMMON.GEO'
12599 !      include 'COMMON.LOCAL'
12600 !      include 'COMMON.INTERACT'
12601       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
12602       real(kind=8),dimension(3,3) :: dp,temp
12603 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
12604       real(kind=8),dimension(3) :: xx,xx1
12605 !el local variables
12606       integer :: i,k,l,j,m,ind,ind1,jjj
12607       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
12608                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
12609                  sint2,xp,yp,xxp,yyp,zzp,dj
12610
12611 !      common /przechowalnia/ fromto
12612       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
12613 ! get the position of the jth ijth fragment of the chain coordinate system
12614 ! in the fromto array.
12615 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12616 !
12617 !      maxdim=(nres-1)*(nres-2)/2
12618 !      allocate(dcdv(6,maxdim),dxds(6,nres))
12619 ! calculate the derivatives of transformation matrix elements in theta
12620 !
12621
12622 !el      call flush(iout) !el
12623       do i=1,nres-2
12624         rdt(1,1,i)=-rt(1,2,i)
12625         rdt(1,2,i)= rt(1,1,i)
12626         rdt(1,3,i)= 0.0d0
12627         rdt(2,1,i)=-rt(2,2,i)
12628         rdt(2,2,i)= rt(2,1,i)
12629         rdt(2,3,i)= 0.0d0
12630         rdt(3,1,i)=-rt(3,2,i)
12631         rdt(3,2,i)= rt(3,1,i)
12632         rdt(3,3,i)= 0.0d0
12633       enddo
12634 !
12635 ! derivatives in phi
12636 !
12637       do i=2,nres-2
12638         drt(1,1,i)= 0.0d0
12639         drt(1,2,i)= 0.0d0
12640         drt(1,3,i)= 0.0d0
12641         drt(2,1,i)= rt(3,1,i)
12642         drt(2,2,i)= rt(3,2,i)
12643         drt(2,3,i)= rt(3,3,i)
12644         drt(3,1,i)=-rt(2,1,i)
12645         drt(3,2,i)=-rt(2,2,i)
12646         drt(3,3,i)=-rt(2,3,i)
12647       enddo
12648 !
12649 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
12650 !
12651       do i=2,nres-2
12652         ind=indmat(i,i+1)
12653         do k=1,3
12654           do l=1,3
12655             temp(k,l)=rt(k,l,i)
12656           enddo
12657         enddo
12658         do k=1,3
12659           do l=1,3
12660             fromto(k,l,ind)=temp(k,l)
12661           enddo
12662         enddo
12663         do j=i+1,nres-2
12664           ind=indmat(i,j+1)
12665           do k=1,3
12666             do l=1,3
12667               dpkl=0.0d0
12668               do m=1,3
12669                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
12670               enddo
12671               dp(k,l)=dpkl
12672               fromto(k,l,ind)=dpkl
12673             enddo
12674           enddo
12675           do k=1,3
12676             do l=1,3
12677               temp(k,l)=dp(k,l)
12678             enddo
12679           enddo
12680         enddo
12681       enddo
12682 !
12683 ! Calculate derivatives.
12684 !
12685       ind1=0
12686       do i=1,nres-2
12687       ind1=ind1+1
12688 !
12689 ! Derivatives of DC(i+1) in theta(i+2)
12690 !
12691         do j=1,3
12692           do k=1,2
12693             dpjk=0.0D0
12694             do l=1,3
12695               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
12696             enddo
12697             dp(j,k)=dpjk
12698             prordt(j,k,i)=dp(j,k)
12699           enddo
12700           dp(j,3)=0.0D0
12701           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
12702         enddo
12703 !
12704 ! Derivatives of SC(i+1) in theta(i+2)
12705 !
12706         xx1(1)=-0.5D0*xloc(2,i+1)
12707         xx1(2)= 0.5D0*xloc(1,i+1)
12708         do j=1,3
12709           xj=0.0D0
12710           do k=1,2
12711             xj=xj+r(j,k,i)*xx1(k)
12712           enddo
12713           xx(j)=xj
12714         enddo
12715         do j=1,3
12716           rj=0.0D0
12717           do k=1,3
12718             rj=rj+prod(j,k,i)*xx(k)
12719           enddo
12720           dxdv(j,ind1)=rj
12721         enddo
12722 !
12723 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
12724 ! than the other off-diagonal derivatives.
12725 !
12726         do j=1,3
12727           dxoiij=0.0D0
12728           do k=1,3
12729             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12730           enddo
12731           dxdv(j,ind1+1)=dxoiij
12732         enddo
12733 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
12734 !
12735 ! Derivatives of DC(i+1) in phi(i+2)
12736 !
12737         do j=1,3
12738           do k=1,3
12739             dpjk=0.0
12740             do l=2,3
12741               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
12742             enddo
12743             dp(j,k)=dpjk
12744             prodrt(j,k,i)=dp(j,k)
12745           enddo
12746           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
12747         enddo
12748 !
12749 ! Derivatives of SC(i+1) in phi(i+2)
12750 !
12751         xx(1)= 0.0D0
12752         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
12753         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
12754         do j=1,3
12755           rj=0.0D0
12756           do k=2,3
12757             rj=rj+prod(j,k,i)*xx(k)
12758           enddo
12759           dxdv(j+3,ind1)=-rj
12760         enddo
12761 !
12762 ! Derivatives of SC(i+1) in phi(i+3).
12763 !
12764         do j=1,3
12765           dxoiij=0.0D0
12766           do k=1,3
12767             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
12768           enddo
12769           dxdv(j+3,ind1+1)=dxoiij
12770         enddo
12771 !
12772 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
12773 ! theta(nres) and phi(i+3) thru phi(nres).
12774 !
12775         do j=i+1,nres-2
12776         ind1=ind1+1
12777         ind=indmat(i+1,j+1)
12778 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
12779           do k=1,3
12780             do l=1,3
12781               tempkl=0.0D0
12782               do m=1,2
12783                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
12784               enddo
12785               temp(k,l)=tempkl
12786             enddo
12787           enddo
12788 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
12789 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
12790 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
12791 ! Derivatives of virtual-bond vectors in theta
12792           do k=1,3
12793             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
12794           enddo
12795 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
12796 ! Derivatives of SC vectors in theta
12797           do k=1,3
12798             dxoijk=0.0D0
12799             do l=1,3
12800               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12801             enddo
12802             dxdv(k,ind1+1)=dxoijk
12803           enddo
12804 !
12805 !--- Calculate the derivatives in phi
12806 !
12807           do k=1,3
12808             do l=1,3
12809               tempkl=0.0D0
12810               do m=1,3
12811                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
12812               enddo
12813               temp(k,l)=tempkl
12814             enddo
12815           enddo
12816           do k=1,3
12817             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
12818         enddo
12819           do k=1,3
12820             dxoijk=0.0D0
12821             do l=1,3
12822               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
12823             enddo
12824             dxdv(k+3,ind1+1)=dxoijk
12825           enddo
12826         enddo
12827       enddo
12828 !
12829 ! Derivatives in alpha and omega:
12830 !
12831       do i=2,nres-1
12832 !       dsci=dsc(itype(i,1))
12833         dsci=vbld(i+nres)
12834 #ifdef OSF
12835         alphi=alph(i)
12836         omegi=omeg(i)
12837         if(alphi.ne.alphi) alphi=100.0
12838         if(omegi.ne.omegi) omegi=-100.0
12839 #else
12840       alphi=alph(i)
12841       omegi=omeg(i)
12842 #endif
12843 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
12844       cosalphi=dcos(alphi)
12845       sinalphi=dsin(alphi)
12846       cosomegi=dcos(omegi)
12847       sinomegi=dsin(omegi)
12848       temp(1,1)=-dsci*sinalphi
12849       temp(2,1)= dsci*cosalphi*cosomegi
12850       temp(3,1)=-dsci*cosalphi*sinomegi
12851       temp(1,2)=0.0D0
12852       temp(2,2)=-dsci*sinalphi*sinomegi
12853       temp(3,2)=-dsci*sinalphi*cosomegi
12854       theta2=pi-0.5D0*theta(i+1)
12855       cost2=dcos(theta2)
12856       sint2=dsin(theta2)
12857       jjj=0
12858 !d      print *,((temp(l,k),l=1,3),k=1,2)
12859         do j=1,2
12860         xp=temp(1,j)
12861         yp=temp(2,j)
12862         xxp= xp*cost2+yp*sint2
12863         yyp=-xp*sint2+yp*cost2
12864         zzp=temp(3,j)
12865         xx(1)=xxp
12866         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
12867         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
12868         do k=1,3
12869           dj=0.0D0
12870           do l=1,3
12871             dj=dj+prod(k,l,i-1)*xx(l)
12872             enddo
12873           dxds(jjj+k,i)=dj
12874           enddo
12875         jjj=jjj+3
12876       enddo
12877       enddo
12878       return
12879       end subroutine cartder
12880 !-----------------------------------------------------------------------------
12881 ! checkder_p.F
12882 !-----------------------------------------------------------------------------
12883       subroutine check_cartgrad
12884 ! Check the gradient of Cartesian coordinates in internal coordinates.
12885 !      implicit real*8 (a-h,o-z)
12886 !      include 'DIMENSIONS'
12887 !      include 'COMMON.IOUNITS'
12888 !      include 'COMMON.VAR'
12889 !      include 'COMMON.CHAIN'
12890 !      include 'COMMON.GEO'
12891 !      include 'COMMON.LOCAL'
12892 !      include 'COMMON.DERIV'
12893       real(kind=8),dimension(6,nres) :: temp
12894       real(kind=8),dimension(3) :: xx,gg
12895       integer :: i,k,j,ii
12896       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
12897 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
12898 !
12899 ! Check the gradient of the virtual-bond and SC vectors in the internal
12900 ! coordinates.
12901 !
12902       aincr=1.0d-6
12903       aincr2=5.0d-7
12904       call cartder
12905       write (iout,'(a)') '**************** dx/dalpha'
12906       write (iout,'(a)')
12907       do i=2,nres-1
12908       alphi=alph(i)
12909       alph(i)=alph(i)+aincr
12910       do k=1,3
12911         temp(k,i)=dc(k,nres+i)
12912         enddo
12913       call chainbuild
12914       do k=1,3
12915         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12916         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
12917         enddo
12918         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12919         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
12920         write (iout,'(a)')
12921       alph(i)=alphi
12922       call chainbuild
12923       enddo
12924       write (iout,'(a)')
12925       write (iout,'(a)') '**************** dx/domega'
12926       write (iout,'(a)')
12927       do i=2,nres-1
12928       omegi=omeg(i)
12929       omeg(i)=omeg(i)+aincr
12930       do k=1,3
12931         temp(k,i)=dc(k,nres+i)
12932         enddo
12933       call chainbuild
12934       do k=1,3
12935           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
12936           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
12937                 (aincr*dabs(dxds(k+3,i))+aincr))
12938         enddo
12939         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
12940             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
12941         write (iout,'(a)')
12942       omeg(i)=omegi
12943       call chainbuild
12944       enddo
12945       write (iout,'(a)')
12946       write (iout,'(a)') '**************** dx/dtheta'
12947       write (iout,'(a)')
12948       do i=3,nres
12949       theti=theta(i)
12950         theta(i)=theta(i)+aincr
12951         do j=i-1,nres-1
12952           do k=1,3
12953             temp(k,j)=dc(k,nres+j)
12954           enddo
12955         enddo
12956         call chainbuild
12957         do j=i-1,nres-1
12958         ii = indmat(i-2,j)
12959 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
12960         do k=1,3
12961           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12962           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
12963                   (aincr*dabs(dxdv(k,ii))+aincr))
12964           enddo
12965           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12966               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
12967           write(iout,'(a)')
12968         enddo
12969         write (iout,'(a)')
12970         theta(i)=theti
12971         call chainbuild
12972       enddo
12973       write (iout,'(a)') '***************** dx/dphi'
12974       write (iout,'(a)')
12975       do i=4,nres
12976         phi(i)=phi(i)+aincr
12977         do j=i-1,nres-1
12978           do k=1,3
12979             temp(k,j)=dc(k,nres+j)
12980           enddo
12981         enddo
12982         call chainbuild
12983         do j=i-1,nres-1
12984         ii = indmat(i-2,j)
12985 !         print *,'ii=',ii
12986         do k=1,3
12987           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
12988             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
12989                   (aincr*dabs(dxdv(k+3,ii))+aincr))
12990           enddo
12991           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
12992               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
12993           write(iout,'(a)')
12994         enddo
12995         phi(i)=phi(i)-aincr
12996         call chainbuild
12997       enddo
12998       write (iout,'(a)') '****************** ddc/dtheta'
12999       do i=1,nres-2
13000         thet=theta(i+2)
13001         theta(i+2)=thet+aincr
13002         do j=i,nres
13003           do k=1,3
13004             temp(k,j)=dc(k,j)
13005           enddo
13006         enddo
13007         call chainbuild
13008         do j=i+1,nres-1
13009         ii = indmat(i,j)
13010 !         print *,'ii=',ii
13011         do k=1,3
13012           gg(k)=(dc(k,j)-temp(k,j))/aincr
13013           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
13014                  (aincr*dabs(dcdv(k,ii))+aincr))
13015           enddo
13016           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
13017                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
13018         write (iout,'(a)')
13019         enddo
13020         do j=1,nres
13021           do k=1,3
13022             dc(k,j)=temp(k,j)
13023           enddo
13024         enddo
13025         theta(i+2)=thet
13026       enddo
13027       write (iout,'(a)') '******************* ddc/dphi'
13028       do i=1,nres-3
13029         phii=phi(i+3)
13030         phi(i+3)=phii+aincr
13031         do j=1,nres
13032           do k=1,3
13033             temp(k,j)=dc(k,j)
13034           enddo
13035         enddo
13036         call chainbuild
13037         do j=i+2,nres-1
13038         ii = indmat(i+1,j)
13039 !         print *,'ii=',ii
13040         do k=1,3
13041           gg(k)=(dc(k,j)-temp(k,j))/aincr
13042             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
13043                  (aincr*dabs(dcdv(k+3,ii))+aincr))
13044           enddo
13045           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
13046                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
13047         write (iout,'(a)')
13048         enddo
13049         do j=1,nres
13050           do k=1,3
13051             dc(k,j)=temp(k,j)
13052           enddo
13053         enddo
13054         phi(i+3)=phii
13055       enddo
13056       return
13057       end subroutine check_cartgrad
13058 !-----------------------------------------------------------------------------
13059       subroutine check_ecart
13060 ! Check the gradient of the energy in Cartesian coordinates.
13061 !     implicit real*8 (a-h,o-z)
13062 !     include 'DIMENSIONS'
13063 !     include 'COMMON.CHAIN'
13064 !     include 'COMMON.DERIV'
13065 !     include 'COMMON.IOUNITS'
13066 !     include 'COMMON.VAR'
13067 !     include 'COMMON.CONTACTS'
13068       use comm_srutu
13069 !el      integer :: icall
13070 !el      common /srutu/ icall
13071       real(kind=8),dimension(6) :: ggg
13072       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
13073       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13074       real(kind=8),dimension(6,nres) :: grad_s
13075       real(kind=8),dimension(0:n_ene) :: energia,energia1
13076       integer :: uiparm(1)
13077       real(kind=8) :: urparm(1)
13078 !EL      external fdum
13079       integer :: nf,i,j,k
13080       real(kind=8) :: aincr,etot,etot1
13081       icg=1
13082       nf=0
13083       nfl=0
13084       call zerograd
13085       aincr=1.0D-5
13086       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
13087       nf=0
13088       icall=0
13089       call geom_to_var(nvar,x)
13090       call etotal(energia)
13091       etot=energia(0)
13092 !el      call enerprint(energia)
13093       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
13094       icall =1
13095       do i=1,nres
13096         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
13097       enddo
13098       do i=1,nres
13099       do j=1,3
13100         grad_s(j,i)=gradc(j,i,icg)
13101         grad_s(j+3,i)=gradx(j,i,icg)
13102         enddo
13103       enddo
13104       call flush(iout)
13105       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
13106       do i=1,nres
13107         do j=1,3
13108         xx(j)=c(j,i+nres)
13109         ddc(j)=dc(j,i)
13110         ddx(j)=dc(j,i+nres)
13111         enddo
13112       do j=1,3
13113         dc(j,i)=dc(j,i)+aincr
13114         do k=i+1,nres
13115           c(j,k)=c(j,k)+aincr
13116           c(j,k+nres)=c(j,k+nres)+aincr
13117           enddo
13118           call zerograd
13119           call etotal(energia1)
13120           etot1=energia1(0)
13121         ggg(j)=(etot1-etot)/aincr
13122         dc(j,i)=ddc(j)
13123         do k=i+1,nres
13124           c(j,k)=c(j,k)-aincr
13125           c(j,k+nres)=c(j,k+nres)-aincr
13126           enddo
13127         enddo
13128       do j=1,3
13129         c(j,i+nres)=c(j,i+nres)+aincr
13130         dc(j,i+nres)=dc(j,i+nres)+aincr
13131           call zerograd
13132           call etotal(energia1)
13133           etot1=energia1(0)
13134         ggg(j+3)=(etot1-etot)/aincr
13135         c(j,i+nres)=xx(j)
13136         dc(j,i+nres)=ddx(j)
13137         enddo
13138       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
13139          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
13140       enddo
13141       return
13142       end subroutine check_ecart
13143 #ifdef CARGRAD
13144 !-----------------------------------------------------------------------------
13145       subroutine check_ecartint
13146 ! Check the gradient of the energy in Cartesian coordinates.
13147       use io_base, only: intout
13148       use MD_data, only: iset
13149 !      implicit real*8 (a-h,o-z)
13150 !      include 'DIMENSIONS'
13151 !      include 'COMMON.CONTROL'
13152 !      include 'COMMON.CHAIN'
13153 !      include 'COMMON.DERIV'
13154 !      include 'COMMON.IOUNITS'
13155 !      include 'COMMON.VAR'
13156 !      include 'COMMON.CONTACTS'
13157 !      include 'COMMON.MD'
13158 !      include 'COMMON.LOCAL'
13159 !      include 'COMMON.SPLITELE'
13160       use comm_srutu
13161 !el      integer :: icall
13162 !el      common /srutu/ icall
13163       real(kind=8),dimension(6) :: ggg,ggg1
13164       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
13165       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13166       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
13167       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
13168       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
13169       real(kind=8),dimension(0:n_ene) :: energia,energia1
13170       integer :: uiparm(1)
13171       real(kind=8) :: urparm(1)
13172 !EL      external fdum
13173       integer :: i,j,k,nf
13174       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
13175                    etot21,etot22
13176       r_cut=2.0d0
13177       rlambd=0.3d0
13178       icg=1
13179       nf=0
13180       nfl=0
13181       if (iset.eq.0) iset=1
13182       call intout
13183 !      call intcartderiv
13184 !      call checkintcartgrad
13185       call zerograd
13186       aincr=1.0D-5
13187       write(iout,*) 'Calling CHECK_ECARTINT.'
13188       nf=0
13189       icall=0
13190       call geom_to_var(nvar,x)
13191       write (iout,*) "split_ene ",split_ene
13192       call flush(iout)
13193       if (.not.split_ene) then
13194         call zerograd
13195         call etotal(energia)
13196         etot=energia(0)
13197         call cartgrad
13198         icall =1
13199         do i=1,nres
13200           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
13201         enddo
13202         do j=1,3
13203           grad_s(j,0)=gcart(j,0)
13204         enddo
13205         do i=1,nres
13206           do j=1,3
13207             grad_s(j,i)=gcart(j,i)
13208             grad_s(j+3,i)=gxcart(j,i)
13209         write(iout,*) "before movement analytical gradient"
13210         do i=1,nres
13211           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13212           (gxcart(j,i),j=1,3)
13213         enddo
13214
13215           enddo
13216         enddo
13217       else
13218 !- split gradient check
13219         call zerograd
13220         call etotal_long(energia)
13221 !el        call enerprint(energia)
13222         call cartgrad
13223         icall =1
13224         do i=1,nres
13225           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13226           (gxcart(j,i),j=1,3)
13227         enddo
13228         do j=1,3
13229           grad_s(j,0)=gcart(j,0)
13230         enddo
13231         do i=1,nres
13232           do j=1,3
13233             grad_s(j,i)=gcart(j,i)
13234             grad_s(j+3,i)=gxcart(j,i)
13235           enddo
13236         enddo
13237         call zerograd
13238         call etotal_short(energia)
13239         call enerprint(energia)
13240         call cartgrad
13241         icall =1
13242         do i=1,nres
13243           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13244           (gxcart(j,i),j=1,3)
13245         enddo
13246         do j=1,3
13247           grad_s1(j,0)=gcart(j,0)
13248         enddo
13249         do i=1,nres
13250           do j=1,3
13251             grad_s1(j,i)=gcart(j,i)
13252             grad_s1(j+3,i)=gxcart(j,i)
13253           enddo
13254         enddo
13255       endif
13256       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
13257 !      do i=1,nres
13258       do i=nnt,nct
13259         do j=1,3
13260           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
13261           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
13262         ddc(j)=c(j,i)
13263         ddx(j)=c(j,i+nres)
13264           dcnorm_safe1(j)=dc_norm(j,i-1)
13265           dcnorm_safe2(j)=dc_norm(j,i)
13266           dxnorm_safe(j)=dc_norm(j,i+nres)
13267         enddo
13268       do j=1,3
13269         c(j,i)=ddc(j)+aincr
13270           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
13271           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
13272           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
13273           dc(j,i)=c(j,i+1)-c(j,i)
13274           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13275           call int_from_cart1(.false.)
13276           if (.not.split_ene) then
13277            call zerograd
13278             call etotal(energia1)
13279             etot1=energia1(0)
13280             write (iout,*) "ij",i,j," etot1",etot1
13281           else
13282 !- split gradient
13283             call etotal_long(energia1)
13284             etot11=energia1(0)
13285             call etotal_short(energia1)
13286             etot12=energia1(0)
13287           endif
13288 !- end split gradient
13289 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13290         c(j,i)=ddc(j)-aincr
13291           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
13292           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
13293           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
13294           dc(j,i)=c(j,i+1)-c(j,i)
13295           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13296           call int_from_cart1(.false.)
13297           if (.not.split_ene) then
13298             call zerograd
13299             call etotal(energia1)
13300             etot2=energia1(0)
13301             write (iout,*) "ij",i,j," etot2",etot2
13302           ggg(j)=(etot1-etot2)/(2*aincr)
13303           else
13304 !- split gradient
13305             call etotal_long(energia1)
13306             etot21=energia1(0)
13307           ggg(j)=(etot11-etot21)/(2*aincr)
13308             call etotal_short(energia1)
13309             etot22=energia1(0)
13310           ggg1(j)=(etot12-etot22)/(2*aincr)
13311 !- end split gradient
13312 !            write (iout,*) "etot21",etot21," etot22",etot22
13313           endif
13314 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13315         c(j,i)=ddc(j)
13316           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
13317           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
13318           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
13319           dc(j,i)=c(j,i+1)-c(j,i)
13320           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13321           dc_norm(j,i-1)=dcnorm_safe1(j)
13322           dc_norm(j,i)=dcnorm_safe2(j)
13323           dc_norm(j,i+nres)=dxnorm_safe(j)
13324         enddo
13325       do j=1,3
13326         c(j,i+nres)=ddx(j)+aincr
13327           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13328           call int_from_cart1(.false.)
13329           if (.not.split_ene) then
13330             call zerograd
13331             call etotal(energia1)
13332             etot1=energia1(0)
13333           else
13334 !- split gradient
13335             call etotal_long(energia1)
13336             etot11=energia1(0)
13337             call etotal_short(energia1)
13338             etot12=energia1(0)
13339           endif
13340 !- end split gradient
13341         c(j,i+nres)=ddx(j)-aincr
13342           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13343           call int_from_cart1(.false.)
13344           if (.not.split_ene) then
13345            call zerograd
13346            call etotal(energia1)
13347             etot2=energia1(0)
13348           ggg(j+3)=(etot1-etot2)/(2*aincr)
13349           else
13350 !- split gradient
13351             call etotal_long(energia1)
13352             etot21=energia1(0)
13353           ggg(j+3)=(etot11-etot21)/(2*aincr)
13354             call etotal_short(energia1)
13355             etot22=energia1(0)
13356           ggg1(j+3)=(etot12-etot22)/(2*aincr)
13357 !- end split gradient
13358           endif
13359 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13360         c(j,i+nres)=ddx(j)
13361           dc(j,i+nres)=c(j,i+nres)-c(j,i)
13362           dc_norm(j,i+nres)=dxnorm_safe(j)
13363           call int_from_cart1(.false.)
13364         enddo
13365       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13366          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
13367         if (split_ene) then
13368           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13369          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
13370          k=1,6)
13371          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13372          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
13373          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
13374         endif
13375       enddo
13376       return
13377       end subroutine check_ecartint
13378 #else
13379 !-----------------------------------------------------------------------------
13380       subroutine check_ecartint
13381 ! Check the gradient of the energy in Cartesian coordinates.
13382       use io_base, only: intout
13383       use MD_data, only: iset
13384 !      implicit real*8 (a-h,o-z)
13385 !      include 'DIMENSIONS'
13386 !      include 'COMMON.CONTROL'
13387 !      include 'COMMON.CHAIN'
13388 !      include 'COMMON.DERIV'
13389 !      include 'COMMON.IOUNITS'
13390 !      include 'COMMON.VAR'
13391 !      include 'COMMON.CONTACTS'
13392 !      include 'COMMON.MD'
13393 !      include 'COMMON.LOCAL'
13394 !      include 'COMMON.SPLITELE'
13395       use comm_srutu
13396 !el      integer :: icall
13397 !el      common /srutu/ icall
13398       real(kind=8),dimension(6) :: ggg,ggg1
13399       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
13400       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
13401       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
13402       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
13403       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
13404       real(kind=8),dimension(0:n_ene) :: energia,energia1
13405       integer :: uiparm(1)
13406       real(kind=8) :: urparm(1)
13407 !EL      external fdum
13408       integer :: i,j,k,nf
13409       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
13410                    etot21,etot22
13411       r_cut=2.0d0
13412       rlambd=0.3d0
13413       icg=1
13414       nf=0
13415       nfl=0
13416       if (iset.eq.0) iset=1
13417       call intout
13418 !      call intcartderiv
13419 !      call checkintcartgrad
13420       call zerograd
13421       aincr=1.0D-6
13422       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
13423       nf=0
13424       icall=0
13425       call geom_to_var(nvar,x)
13426       if (.not.split_ene) then
13427         call etotal(energia)
13428         etot=energia(0)
13429 !el        call enerprint(energia)
13430         call cartgrad
13431         icall =1
13432         do i=1,nres
13433           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
13434         enddo
13435         do j=1,3
13436           grad_s(j,0)=gcart(j,0)
13437           grad_s(j+3,0)=gxcart(j,0)
13438         enddo
13439         do i=1,nres
13440           do j=1,3
13441             grad_s(j,i)=gcart(j,i)
13442             grad_s(j+3,i)=gxcart(j,i)
13443           enddo
13444         enddo
13445         write(iout,*) "before movement analytical gradient"
13446         do i=1,nres
13447           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13448           (gxcart(j,i),j=1,3)
13449         enddo
13450
13451       else
13452 !- split gradient check
13453         call zerograd
13454         call etotal_long(energia)
13455 !el        call enerprint(energia)
13456         call cartgrad
13457         icall =1
13458         do i=1,nres
13459           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13460           (gxcart(j,i),j=1,3)
13461         enddo
13462         do j=1,3
13463           grad_s(j,0)=gcart(j,0)
13464         enddo
13465         do i=1,nres
13466           do j=1,3
13467             grad_s(j,i)=gcart(j,i)
13468 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
13469             grad_s(j+3,i)=gxcart(j,i)
13470           enddo
13471         enddo
13472         call zerograd
13473         call etotal_short(energia)
13474 !el        call enerprint(energia)
13475         call cartgrad
13476         icall =1
13477         do i=1,nres
13478           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
13479           (gxcart(j,i),j=1,3)
13480         enddo
13481         do j=1,3
13482           grad_s1(j,0)=gcart(j,0)
13483         enddo
13484         do i=1,nres
13485           do j=1,3
13486             grad_s1(j,i)=gcart(j,i)
13487             grad_s1(j+3,i)=gxcart(j,i)
13488           enddo
13489         enddo
13490       endif
13491       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
13492       do i=0,nres
13493         do j=1,3
13494         xx(j)=c(j,i+nres)
13495         ddc(j)=dc(j,i)
13496         ddx(j)=dc(j,i+nres)
13497           do k=1,3
13498             dcnorm_safe(k)=dc_norm(k,i)
13499             dxnorm_safe(k)=dc_norm(k,i+nres)
13500           enddo
13501         enddo
13502       do j=1,3
13503         dc(j,i)=ddc(j)+aincr
13504           call chainbuild_cart
13505 #ifdef MPI
13506 ! Broadcast the order to compute internal coordinates to the slaves.
13507 !          if (nfgtasks.gt.1)
13508 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
13509 #endif
13510 !          call int_from_cart1(.false.)
13511           if (.not.split_ene) then
13512            call zerograd
13513             call etotal(energia1)
13514             etot1=energia1(0)
13515 !            call enerprint(energia1)
13516           else
13517 !- split gradient
13518             call etotal_long(energia1)
13519             etot11=energia1(0)
13520             call etotal_short(energia1)
13521             etot12=energia1(0)
13522 !            write (iout,*) "etot11",etot11," etot12",etot12
13523           endif
13524 !- end split gradient
13525 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13526         dc(j,i)=ddc(j)-aincr
13527           call chainbuild_cart
13528 !          call int_from_cart1(.false.)
13529           if (.not.split_ene) then
13530                   call zerograd
13531             call etotal(energia1)
13532             etot2=energia1(0)
13533           ggg(j)=(etot1-etot2)/(2*aincr)
13534           else
13535 !- split gradient
13536             call etotal_long(energia1)
13537             etot21=energia1(0)
13538           ggg(j)=(etot11-etot21)/(2*aincr)
13539             call etotal_short(energia1)
13540             etot22=energia1(0)
13541           ggg1(j)=(etot12-etot22)/(2*aincr)
13542 !- end split gradient
13543 !            write (iout,*) "etot21",etot21," etot22",etot22
13544           endif
13545 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13546         dc(j,i)=ddc(j)
13547           call chainbuild_cart
13548         enddo
13549       do j=1,3
13550         dc(j,i+nres)=ddx(j)+aincr
13551           call chainbuild_cart
13552 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
13553 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
13554 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
13555 !          write (iout,*) "dxnormnorm",dsqrt(
13556 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
13557 !          write (iout,*) "dxnormnormsafe",dsqrt(
13558 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
13559 !          write (iout,*)
13560           if (.not.split_ene) then
13561             call zerograd
13562             call etotal(energia1)
13563             etot1=energia1(0)
13564           else
13565 !- split gradient
13566             call etotal_long(energia1)
13567             etot11=energia1(0)
13568             call etotal_short(energia1)
13569             etot12=energia1(0)
13570           endif
13571 !- end split gradient
13572 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
13573         dc(j,i+nres)=ddx(j)-aincr
13574           call chainbuild_cart
13575 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
13576 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
13577 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
13578 !          write (iout,*)
13579 !          write (iout,*) "dxnormnorm",dsqrt(
13580 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
13581 !          write (iout,*) "dxnormnormsafe",dsqrt(
13582 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
13583           if (.not.split_ene) then
13584             call zerograd
13585             call etotal(energia1)
13586             etot2=energia1(0)
13587           ggg(j+3)=(etot1-etot2)/(2*aincr)
13588           else
13589 !- split gradient
13590             call etotal_long(energia1)
13591             etot21=energia1(0)
13592           ggg(j+3)=(etot11-etot21)/(2*aincr)
13593             call etotal_short(energia1)
13594             etot22=energia1(0)
13595           ggg1(j+3)=(etot12-etot22)/(2*aincr)
13596 !- end split gradient
13597           endif
13598 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
13599         dc(j,i+nres)=ddx(j)
13600           call chainbuild_cart
13601         enddo
13602       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13603          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
13604         if (split_ene) then
13605           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13606          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
13607          k=1,6)
13608          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
13609          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
13610          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
13611         endif
13612       enddo
13613       return
13614       end subroutine check_ecartint
13615 #endif
13616 !-----------------------------------------------------------------------------
13617       subroutine check_eint
13618 ! Check the gradient of energy in internal coordinates.
13619 !      implicit real*8 (a-h,o-z)
13620 !      include 'DIMENSIONS'
13621 !      include 'COMMON.CHAIN'
13622 !      include 'COMMON.DERIV'
13623 !      include 'COMMON.IOUNITS'
13624 !      include 'COMMON.VAR'
13625 !      include 'COMMON.GEO'
13626       use comm_srutu
13627 !el      integer :: icall
13628 !el      common /srutu/ icall
13629       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
13630       integer :: uiparm(1)
13631       real(kind=8) :: urparm(1)
13632       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
13633       character(len=6) :: key
13634 !EL      external fdum
13635       integer :: i,ii,nf
13636       real(kind=8) :: xi,aincr,etot,etot1,etot2
13637       call zerograd
13638       aincr=1.0D-7
13639       print '(a)','Calling CHECK_INT.'
13640       nf=0
13641       nfl=0
13642       icg=1
13643       call geom_to_var(nvar,x)
13644       call var_to_geom(nvar,x)
13645       call chainbuild
13646       icall=1
13647 !      print *,'ICG=',ICG
13648       call etotal(energia)
13649       etot = energia(0)
13650 !el      call enerprint(energia)
13651 !      print *,'ICG=',ICG
13652 #ifdef MPL
13653       if (MyID.ne.BossID) then
13654         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
13655         nf=x(nvar+1)
13656         nfl=x(nvar+2)
13657         icg=x(nvar+3)
13658       endif
13659 #endif
13660       nf=1
13661       nfl=3
13662 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
13663       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
13664 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
13665       icall=1
13666       do i=1,nvar
13667         xi=x(i)
13668         x(i)=xi-0.5D0*aincr
13669         call var_to_geom(nvar,x)
13670         call chainbuild
13671         call etotal(energia1)
13672         etot1=energia1(0)
13673         x(i)=xi+0.5D0*aincr
13674         call var_to_geom(nvar,x)
13675         call chainbuild
13676         call etotal(energia2)
13677         etot2=energia2(0)
13678         gg(i)=(etot2-etot1)/aincr
13679         write (iout,*) i,etot1,etot2
13680         x(i)=xi
13681       enddo
13682       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
13683           '     RelDiff*100% '
13684       do i=1,nvar
13685         if (i.le.nphi) then
13686           ii=i
13687           key = ' phi'
13688         else if (i.le.nphi+ntheta) then
13689           ii=i-nphi
13690           key=' theta'
13691         else if (i.le.nphi+ntheta+nside) then
13692            ii=i-(nphi+ntheta)
13693            key=' alpha'
13694         else
13695            ii=i-(nphi+ntheta+nside)
13696            key=' omega'
13697         endif
13698         write (iout,'(i3,a,i3,3(1pd16.6))') &
13699        i,key,ii,gg(i),gana(i),&
13700        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
13701       enddo
13702       return
13703       end subroutine check_eint
13704 !-----------------------------------------------------------------------------
13705 ! econstr_local.F
13706 !-----------------------------------------------------------------------------
13707       subroutine Econstr_back
13708 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
13709 !      implicit real*8 (a-h,o-z)
13710 !      include 'DIMENSIONS'
13711 !      include 'COMMON.CONTROL'
13712 !      include 'COMMON.VAR'
13713 !      include 'COMMON.MD'
13714       use MD_data
13715 !#ifndef LANG0
13716 !      include 'COMMON.LANGEVIN'
13717 !#else
13718 !      include 'COMMON.LANGEVIN.lang0'
13719 !#endif
13720 !      include 'COMMON.CHAIN'
13721 !      include 'COMMON.DERIV'
13722 !      include 'COMMON.GEO'
13723 !      include 'COMMON.LOCAL'
13724 !      include 'COMMON.INTERACT'
13725 !      include 'COMMON.IOUNITS'
13726 !      include 'COMMON.NAMES'
13727 !      include 'COMMON.TIME1'
13728       integer :: i,j,ii,k
13729       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
13730
13731       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
13732       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
13733       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
13734
13735       Uconst_back=0.0d0
13736       do i=1,nres
13737         dutheta(i)=0.0d0
13738         dugamma(i)=0.0d0
13739         do j=1,3
13740           duscdiff(j,i)=0.0d0
13741           duscdiffx(j,i)=0.0d0
13742         enddo
13743       enddo
13744       do i=1,nfrag_back
13745         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
13746 !
13747 ! Deviations from theta angles
13748 !
13749         utheta_i=0.0d0
13750         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
13751           dtheta_i=theta(j)-thetaref(j)
13752           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
13753           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
13754         enddo
13755         utheta(i)=utheta_i/(ii-1)
13756 !
13757 ! Deviations from gamma angles
13758 !
13759         ugamma_i=0.0d0
13760         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
13761           dgamma_i=pinorm(phi(j)-phiref(j))
13762 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
13763           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
13764           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
13765 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
13766         enddo
13767         ugamma(i)=ugamma_i/(ii-2)
13768 !
13769 ! Deviations from local SC geometry
13770 !
13771         uscdiff(i)=0.0d0
13772         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
13773           dxx=xxtab(j)-xxref(j)
13774           dyy=yytab(j)-yyref(j)
13775           dzz=zztab(j)-zzref(j)
13776           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
13777           do k=1,3
13778             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
13779              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
13780              (ii-1)
13781             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
13782              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
13783              (ii-1)
13784             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
13785            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
13786             /(ii-1)
13787           enddo
13788 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
13789 !     &      xxref(j),yyref(j),zzref(j)
13790         enddo
13791         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
13792 !        write (iout,*) i," uscdiff",uscdiff(i)
13793 !
13794 ! Put together deviations from local geometry
13795 !
13796         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
13797           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
13798 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
13799 !     &   " uconst_back",uconst_back
13800         utheta(i)=dsqrt(utheta(i))
13801         ugamma(i)=dsqrt(ugamma(i))
13802         uscdiff(i)=dsqrt(uscdiff(i))
13803       enddo
13804       return
13805       end subroutine Econstr_back
13806 !-----------------------------------------------------------------------------
13807 ! energy_p_new-sep_barrier.F
13808 !-----------------------------------------------------------------------------
13809       real(kind=8) function sscale(r)
13810 !      include "COMMON.SPLITELE"
13811       real(kind=8) :: r,gamm
13812       if(r.lt.r_cut-rlamb) then
13813         sscale=1.0d0
13814       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13815         gamm=(r-(r_cut-rlamb))/rlamb
13816         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13817       else
13818         sscale=0d0
13819       endif
13820       return
13821       end function sscale
13822       real(kind=8) function sscale_grad(r)
13823 !      include "COMMON.SPLITELE"
13824       real(kind=8) :: r,gamm
13825       if(r.lt.r_cut-rlamb) then
13826         sscale_grad=0.0d0
13827       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
13828         gamm=(r-(r_cut-rlamb))/rlamb
13829         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
13830       else
13831         sscale_grad=0d0
13832       endif
13833       return
13834       end function sscale_grad
13835
13836 !!!!!!!!!! PBCSCALE
13837       real(kind=8) function sscale_ele(r)
13838 !      include "COMMON.SPLITELE"
13839       real(kind=8) :: r,gamm
13840       if(r.lt.r_cut_ele-rlamb_ele) then
13841         sscale_ele=1.0d0
13842       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13843         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13844         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
13845       else
13846         sscale_ele=0d0
13847       endif
13848       return
13849       end function sscale_ele
13850
13851       real(kind=8)  function sscagrad_ele(r)
13852       real(kind=8) :: r,gamm
13853 !      include "COMMON.SPLITELE"
13854       if(r.lt.r_cut_ele-rlamb_ele) then
13855         sscagrad_ele=0.0d0
13856       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
13857         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
13858         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
13859       else
13860         sscagrad_ele=0.0d0
13861       endif
13862       return
13863       end function sscagrad_ele
13864       real(kind=8) function sscalelip(r)
13865       real(kind=8) r,gamm
13866         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
13867       return
13868       end function sscalelip
13869 !C-----------------------------------------------------------------------
13870       real(kind=8) function sscagradlip(r)
13871       real(kind=8) r,gamm
13872         sscagradlip=r*(6.0d0*r-6.0d0)
13873       return
13874       end function sscagradlip
13875
13876 !!!!!!!!!!!!!!!
13877 !-----------------------------------------------------------------------------
13878       subroutine elj_long(evdw)
13879 !
13880 ! This subroutine calculates the interaction energy of nonbonded side chains
13881 ! assuming the LJ potential of interaction.
13882 !
13883 !      implicit real*8 (a-h,o-z)
13884 !      include 'DIMENSIONS'
13885 !      include 'COMMON.GEO'
13886 !      include 'COMMON.VAR'
13887 !      include 'COMMON.LOCAL'
13888 !      include 'COMMON.CHAIN'
13889 !      include 'COMMON.DERIV'
13890 !      include 'COMMON.INTERACT'
13891 !      include 'COMMON.TORSION'
13892 !      include 'COMMON.SBRIDGE'
13893 !      include 'COMMON.NAMES'
13894 !      include 'COMMON.IOUNITS'
13895 !      include 'COMMON.CONTACTS'
13896       real(kind=8),parameter :: accur=1.0d-10
13897       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
13898 !el local variables
13899       integer :: i,iint,j,k,itypi,itypi1,itypj
13900       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
13901       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
13902                       sslipj,ssgradlipj,aa,bb
13903 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
13904       evdw=0.0D0
13905       do i=iatsc_s,iatsc_e
13906         itypi=itype(i,1)
13907         if (itypi.eq.ntyp1) cycle
13908         itypi1=itype(i+1,1)
13909         xi=c(1,nres+i)
13910         yi=c(2,nres+i)
13911         zi=c(3,nres+i)
13912         call to_box(xi,yi,zi)
13913         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
13914 !
13915 ! Calculate SC interaction energy.
13916 !
13917         do iint=1,nint_gr(i)
13918 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
13919 !d   &                  'iend=',iend(i,iint)
13920           do j=istart(i,iint),iend(i,iint)
13921             itypj=itype(j,1)
13922             if (itypj.eq.ntyp1) cycle
13923             xj=c(1,nres+j)-xi
13924             yj=c(2,nres+j)-yi
13925             zj=c(3,nres+j)-zi
13926             call to_box(xj,yj,zj)
13927             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
13928             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13929              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13930             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13931              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13932             xj=boxshift(xj-xi,boxxsize)
13933             yj=boxshift(yj-yi,boxysize)
13934             zj=boxshift(zj-zi,boxzsize)
13935             rij=xj*xj+yj*yj+zj*zj
13936             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
13937             if (sss.lt.1.0d0) then
13938               rrij=1.0D0/rij
13939               eps0ij=eps(itypi,itypj)
13940               fac=rrij**expon2
13941               e1=fac*fac*aa_aq(itypi,itypj)
13942               e2=fac*bb_aq(itypi,itypj)
13943               evdwij=e1+e2
13944               evdw=evdw+(1.0d0-sss)*evdwij
13945 !
13946 ! Calculate the components of the gradient in DC and X
13947 !
13948               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
13949               gg(1)=xj*fac
13950               gg(2)=yj*fac
13951               gg(3)=zj*fac
13952               do k=1,3
13953                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13954                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13955                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13956                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13957               enddo
13958             endif
13959           enddo      ! j
13960         enddo        ! iint
13961       enddo          ! i
13962       do i=1,nct
13963         do j=1,3
13964           gvdwc(j,i)=expon*gvdwc(j,i)
13965           gvdwx(j,i)=expon*gvdwx(j,i)
13966         enddo
13967       enddo
13968 !******************************************************************************
13969 !
13970 !                              N O T E !!!
13971 !
13972 ! To save time, the factor of EXPON has been extracted from ALL components
13973 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
13974 ! use!
13975 !
13976 !******************************************************************************
13977       return
13978       end subroutine elj_long
13979 !-----------------------------------------------------------------------------
13980       subroutine elj_short(evdw)
13981 !
13982 ! This subroutine calculates the interaction energy of nonbonded side chains
13983 ! assuming the LJ potential of interaction.
13984 !
13985 !      implicit real*8 (a-h,o-z)
13986 !      include 'DIMENSIONS'
13987 !      include 'COMMON.GEO'
13988 !      include 'COMMON.VAR'
13989 !      include 'COMMON.LOCAL'
13990 !      include 'COMMON.CHAIN'
13991 !      include 'COMMON.DERIV'
13992 !      include 'COMMON.INTERACT'
13993 !      include 'COMMON.TORSION'
13994 !      include 'COMMON.SBRIDGE'
13995 !      include 'COMMON.NAMES'
13996 !      include 'COMMON.IOUNITS'
13997 !      include 'COMMON.CONTACTS'
13998       real(kind=8),parameter :: accur=1.0d-10
13999       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
14000 !el local variables
14001       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
14002       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
14003       real(kind=8) :: e1,e2,evdwij,evdw,sslipi,ssgradlipi,&
14004                       sslipj,ssgradlipj
14005 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
14006       evdw=0.0D0
14007       do i=iatsc_s,iatsc_e
14008         itypi=itype(i,1)
14009         if (itypi.eq.ntyp1) cycle
14010         itypi1=itype(i+1,1)
14011         xi=c(1,nres+i)
14012         yi=c(2,nres+i)
14013         zi=c(3,nres+i)
14014         call to_box(xi,yi,zi)
14015         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14016 ! Change 12/1/95
14017         num_conti=0
14018 !
14019 ! Calculate SC interaction energy.
14020 !
14021         do iint=1,nint_gr(i)
14022 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
14023 !d   &                  'iend=',iend(i,iint)
14024           do j=istart(i,iint),iend(i,iint)
14025             itypj=itype(j,1)
14026             if (itypj.eq.ntyp1) cycle
14027             xj=c(1,nres+j)-xi
14028             yj=c(2,nres+j)-yi
14029             zj=c(3,nres+j)-zi
14030 ! Change 12/1/95 to calculate four-body interactions
14031             rij=xj*xj+yj*yj+zj*zj
14032             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
14033             if (sss.gt.0.0d0) then
14034               rrij=1.0D0/rij
14035               eps0ij=eps(itypi,itypj)
14036               fac=rrij**expon2
14037               e1=fac*fac*aa_aq(itypi,itypj)
14038               e2=fac*bb_aq(itypi,itypj)
14039               evdwij=e1+e2
14040               evdw=evdw+sss*evdwij
14041 !
14042 ! Calculate the components of the gradient in DC and X
14043 !
14044               fac=-rrij*(e1+evdwij)*sss
14045               gg(1)=xj*fac
14046               gg(2)=yj*fac
14047               gg(3)=zj*fac
14048               do k=1,3
14049                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
14050                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
14051                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
14052                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
14053               enddo
14054             endif
14055           enddo      ! j
14056         enddo        ! iint
14057       enddo          ! i
14058       do i=1,nct
14059         do j=1,3
14060           gvdwc(j,i)=expon*gvdwc(j,i)
14061           gvdwx(j,i)=expon*gvdwx(j,i)
14062         enddo
14063       enddo
14064 !******************************************************************************
14065 !
14066 !                              N O T E !!!
14067 !
14068 ! To save time, the factor of EXPON has been extracted from ALL components
14069 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
14070 ! use!
14071 !
14072 !******************************************************************************
14073       return
14074       end subroutine elj_short
14075 !-----------------------------------------------------------------------------
14076       subroutine eljk_long(evdw)
14077 !
14078 ! This subroutine calculates the interaction energy of nonbonded side chains
14079 ! assuming the LJK potential of interaction.
14080 !
14081 !      implicit real*8 (a-h,o-z)
14082 !      include 'DIMENSIONS'
14083 !      include 'COMMON.GEO'
14084 !      include 'COMMON.VAR'
14085 !      include 'COMMON.LOCAL'
14086 !      include 'COMMON.CHAIN'
14087 !      include 'COMMON.DERIV'
14088 !      include 'COMMON.INTERACT'
14089 !      include 'COMMON.IOUNITS'
14090 !      include 'COMMON.NAMES'
14091       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
14092       logical :: scheck
14093 !el local variables
14094       integer :: i,iint,j,k,itypi,itypi1,itypj
14095       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
14096                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
14097 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
14098       evdw=0.0D0
14099       do i=iatsc_s,iatsc_e
14100         itypi=itype(i,1)
14101         if (itypi.eq.ntyp1) cycle
14102         itypi1=itype(i+1,1)
14103         xi=c(1,nres+i)
14104         yi=c(2,nres+i)
14105         zi=c(3,nres+i)
14106           call to_box(xi,yi,zi)
14107
14108 !
14109 ! Calculate SC interaction energy.
14110 !
14111         do iint=1,nint_gr(i)
14112           do j=istart(i,iint),iend(i,iint)
14113             itypj=itype(j,1)
14114             if (itypj.eq.ntyp1) cycle
14115             xj=c(1,nres+j)-xi
14116             yj=c(2,nres+j)-yi
14117             zj=c(3,nres+j)-zi
14118           call to_box(xj,yj,zj)
14119       xj=boxshift(xj-xi,boxxsize)
14120       yj=boxshift(yj-yi,boxysize)
14121       zj=boxshift(zj-zi,boxzsize)
14122
14123             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14124             fac_augm=rrij**expon
14125             e_augm=augm(itypi,itypj)*fac_augm
14126             r_inv_ij=dsqrt(rrij)
14127             rij=1.0D0/r_inv_ij
14128             sss=sscale(rij/sigma(itypi,itypj))
14129             if (sss.lt.1.0d0) then
14130               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
14131               fac=r_shift_inv**expon
14132               e1=fac*fac*aa_aq(itypi,itypj)
14133               e2=fac*bb_aq(itypi,itypj)
14134               evdwij=e_augm+e1+e2
14135 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
14136 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
14137 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
14138 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
14139 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
14140 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
14141 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
14142               evdw=evdw+(1.0d0-sss)*evdwij
14143 !
14144 ! Calculate the components of the gradient in DC and X
14145 !
14146               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
14147               fac=fac*(1.0d0-sss)
14148               gg(1)=xj*fac
14149               gg(2)=yj*fac
14150               gg(3)=zj*fac
14151               do k=1,3
14152                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
14153                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
14154                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
14155                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
14156               enddo
14157             endif
14158           enddo      ! j
14159         enddo        ! iint
14160       enddo          ! i
14161       do i=1,nct
14162         do j=1,3
14163           gvdwc(j,i)=expon*gvdwc(j,i)
14164           gvdwx(j,i)=expon*gvdwx(j,i)
14165         enddo
14166       enddo
14167       return
14168       end subroutine eljk_long
14169 !-----------------------------------------------------------------------------
14170       subroutine eljk_short(evdw)
14171 !
14172 ! This subroutine calculates the interaction energy of nonbonded side chains
14173 ! assuming the LJK potential of interaction.
14174 !
14175 !      implicit real*8 (a-h,o-z)
14176 !      include 'DIMENSIONS'
14177 !      include 'COMMON.GEO'
14178 !      include 'COMMON.VAR'
14179 !      include 'COMMON.LOCAL'
14180 !      include 'COMMON.CHAIN'
14181 !      include 'COMMON.DERIV'
14182 !      include 'COMMON.INTERACT'
14183 !      include 'COMMON.IOUNITS'
14184 !      include 'COMMON.NAMES'
14185       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
14186       logical :: scheck
14187 !el local variables
14188       integer :: i,iint,j,k,itypi,itypi1,itypj
14189       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
14190                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij,&
14191                    sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
14192 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
14193       evdw=0.0D0
14194       do i=iatsc_s,iatsc_e
14195         itypi=itype(i,1)
14196         if (itypi.eq.ntyp1) cycle
14197         itypi1=itype(i+1,1)
14198         xi=c(1,nres+i)
14199         yi=c(2,nres+i)
14200         zi=c(3,nres+i)
14201         call to_box(xi,yi,zi)
14202         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14203 !
14204 ! Calculate SC interaction energy.
14205 !
14206         do iint=1,nint_gr(i)
14207           do j=istart(i,iint),iend(i,iint)
14208             itypj=itype(j,1)
14209             if (itypj.eq.ntyp1) cycle
14210             xj=c(1,nres+j)-xi
14211             yj=c(2,nres+j)-yi
14212             zj=c(3,nres+j)-zi
14213             call to_box(xj,yj,zj)
14214             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14215             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14216              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14217             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14218              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14219             xj=boxshift(xj-xi,boxxsize)
14220             yj=boxshift(yj-yi,boxysize)
14221             zj=boxshift(zj-zi,boxzsize)
14222             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14223             fac_augm=rrij**expon
14224             e_augm=augm(itypi,itypj)*fac_augm
14225             r_inv_ij=dsqrt(rrij)
14226             rij=1.0D0/r_inv_ij
14227             sss=sscale(rij/sigma(itypi,itypj))
14228             if (sss.gt.0.0d0) then
14229               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
14230               fac=r_shift_inv**expon
14231               e1=fac*fac*aa_aq(itypi,itypj)
14232               e2=fac*bb_aq(itypi,itypj)
14233               evdwij=e_augm+e1+e2
14234 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
14235 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
14236 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
14237 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
14238 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
14239 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
14240 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
14241               evdw=evdw+sss*evdwij
14242 !
14243 ! Calculate the components of the gradient in DC and X
14244 !
14245               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
14246               fac=fac*sss
14247               gg(1)=xj*fac
14248               gg(2)=yj*fac
14249               gg(3)=zj*fac
14250               do k=1,3
14251                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
14252                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
14253                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
14254                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
14255               enddo
14256             endif
14257           enddo      ! j
14258         enddo        ! iint
14259       enddo          ! i
14260       do i=1,nct
14261         do j=1,3
14262           gvdwc(j,i)=expon*gvdwc(j,i)
14263           gvdwx(j,i)=expon*gvdwx(j,i)
14264         enddo
14265       enddo
14266       return
14267       end subroutine eljk_short
14268 !-----------------------------------------------------------------------------
14269        subroutine ebp_long(evdw)
14270 ! This subroutine calculates the interaction energy of nonbonded side chains
14271 ! assuming the Berne-Pechukas potential of interaction.
14272 !
14273        use calc_data
14274 !      implicit real*8 (a-h,o-z)
14275 !      include 'DIMENSIONS'
14276 !      include 'COMMON.GEO'
14277 !      include 'COMMON.VAR'
14278 !      include 'COMMON.LOCAL'
14279 !      include 'COMMON.CHAIN'
14280 !      include 'COMMON.DERIV'
14281 !      include 'COMMON.NAMES'
14282 !      include 'COMMON.INTERACT'
14283 !      include 'COMMON.IOUNITS'
14284 !      include 'COMMON.CALC'
14285        use comm_srutu
14286 !el      integer :: icall
14287 !el      common /srutu/ icall
14288 !     double precision rrsave(maxdim)
14289         logical :: lprn
14290 !el local variables
14291         integer :: iint,itypi,itypi1,itypj
14292         real(kind=8) :: rrij,xi,yi,zi,fac,sslipi,ssgradlipi,&
14293                         sslipj,ssgradlipj,aa,bb
14294         real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
14295         evdw=0.0D0
14296 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
14297         evdw=0.0D0
14298 !     if (icall.eq.0) then
14299 !       lprn=.true.
14300 !     else
14301       lprn=.false.
14302 !     endif
14303 !el      ind=0
14304       do i=iatsc_s,iatsc_e
14305       itypi=itype(i,1)
14306       if (itypi.eq.ntyp1) cycle
14307       itypi1=itype(i+1,1)
14308       xi=c(1,nres+i)
14309       yi=c(2,nres+i)
14310       zi=c(3,nres+i)
14311         call to_box(xi,yi,zi)
14312         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14313       dxi=dc_norm(1,nres+i)
14314       dyi=dc_norm(2,nres+i)
14315       dzi=dc_norm(3,nres+i)
14316 !        dsci_inv=dsc_inv(itypi)
14317       dsci_inv=vbld_inv(i+nres)
14318 !
14319 ! Calculate SC interaction energy.
14320 !
14321       do iint=1,nint_gr(i)
14322       do j=istart(i,iint),iend(i,iint)
14323 !el            ind=ind+1
14324       itypj=itype(j,1)
14325       if (itypj.eq.ntyp1) cycle
14326 !            dscj_inv=dsc_inv(itypj)
14327       dscj_inv=vbld_inv(j+nres)
14328 chi1=chi(itypi,itypj)
14329 chi2=chi(itypj,itypi)
14330 chi12=chi1*chi2
14331 chip1=chip(itypi)
14332       alf1=alp(itypi)
14333       alf2=alp(itypj)
14334       alf12=0.5D0*(alf1+alf2)
14335         xj=c(1,nres+j)-xi
14336         yj=c(2,nres+j)-yi
14337         zj=c(3,nres+j)-zi
14338             call to_box(xj,yj,zj)
14339             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14340             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14341              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14342             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14343              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14344             xj=boxshift(xj-xi,boxxsize)
14345             yj=boxshift(yj-yi,boxysize)
14346             zj=boxshift(zj-zi,boxzsize)
14347         dxj=dc_norm(1,nres+j)
14348         dyj=dc_norm(2,nres+j)
14349         dzj=dc_norm(3,nres+j)
14350         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14351         rij=dsqrt(rrij)
14352       sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14353
14354         if (sss.lt.1.0d0) then
14355
14356         ! Calculate the angle-dependent terms of energy & contributions to derivatives.
14357         call sc_angular
14358         ! Calculate whole angle-dependent part of epsilon and contributions
14359         ! to its derivatives
14360         fac=(rrij*sigsq)**expon2
14361         e1=fac*fac*aa_aq(itypi,itypj)
14362         e2=fac*bb_aq(itypi,itypj)
14363       evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14364         eps2der=evdwij*eps3rt
14365         eps3der=evdwij*eps2rt
14366         evdwij=evdwij*eps2rt*eps3rt
14367       evdw=evdw+evdwij*(1.0d0-sss)
14368         if (lprn) then
14369         sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14370       epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14371         !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
14372         !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14373         !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
14374         !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
14375         !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
14376         !d     &          evdwij
14377         endif
14378         ! Calculate gradient components.
14379         e1=e1*eps1*eps2rt**2*eps3rt**2
14380       fac=-expon*(e1+evdwij)
14381         sigder=fac/sigsq
14382         fac=rrij*fac
14383         ! Calculate radial part of the gradient
14384         gg(1)=xj*fac
14385         gg(2)=yj*fac
14386         gg(3)=zj*fac
14387         ! Calculate the angular part of the gradient and sum add the contributions
14388         ! to the appropriate components of the Cartesian gradient.
14389       call sc_grad_scale(1.0d0-sss)
14390         endif
14391         enddo      ! j
14392         enddo        ! iint
14393         enddo          ! i
14394         !     stop
14395         return
14396         end subroutine ebp_long
14397         !-----------------------------------------------------------------------------
14398       subroutine ebp_short(evdw)
14399         !
14400         ! This subroutine calculates the interaction energy of nonbonded side chains
14401         ! assuming the Berne-Pechukas potential of interaction.
14402         !
14403         use calc_data
14404 !      implicit real*8 (a-h,o-z)
14405         !      include 'DIMENSIONS'
14406         !      include 'COMMON.GEO'
14407         !      include 'COMMON.VAR'
14408         !      include 'COMMON.LOCAL'
14409         !      include 'COMMON.CHAIN'
14410         !      include 'COMMON.DERIV'
14411         !      include 'COMMON.NAMES'
14412         !      include 'COMMON.INTERACT'
14413         !      include 'COMMON.IOUNITS'
14414         !      include 'COMMON.CALC'
14415         use comm_srutu
14416         !el      integer :: icall
14417         !el      common /srutu/ icall
14418 !     double precision rrsave(maxdim)
14419         logical :: lprn
14420         !el local variables
14421         integer :: iint,itypi,itypi1,itypj
14422         real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
14423         real(kind=8) :: sss,e1,e2,evdw,aa,bb, &
14424         sslipi,ssgradlipi,sslipj,ssgradlipj
14425         evdw=0.0D0
14426         !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
14427         evdw=0.0D0
14428         !     if (icall.eq.0) then
14429         !       lprn=.true.
14430         !     else
14431         lprn=.false.
14432         !     endif
14433         !el      ind=0
14434         do i=iatsc_s,iatsc_e
14435       itypi=itype(i,1)
14436         if (itypi.eq.ntyp1) cycle
14437         itypi1=itype(i+1,1)
14438         xi=c(1,nres+i)
14439         yi=c(2,nres+i)
14440         zi=c(3,nres+i)
14441         call to_box(xi,yi,zi)
14442       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14443
14444         dxi=dc_norm(1,nres+i)
14445         dyi=dc_norm(2,nres+i)
14446         dzi=dc_norm(3,nres+i)
14447         !        dsci_inv=dsc_inv(itypi)
14448       dsci_inv=vbld_inv(i+nres)
14449         !
14450         ! Calculate SC interaction energy.
14451         !
14452         do iint=1,nint_gr(i)
14453       do j=istart(i,iint),iend(i,iint)
14454         !el            ind=ind+1
14455       itypj=itype(j,1)
14456         if (itypj.eq.ntyp1) cycle
14457         !            dscj_inv=dsc_inv(itypj)
14458         dscj_inv=vbld_inv(j+nres)
14459         chi1=chi(itypi,itypj)
14460       chi2=chi(itypj,itypi)
14461         chi12=chi1*chi2
14462         chip1=chip(itypi)
14463       chip2=chip(itypj)
14464         chip12=chip1*chip2
14465         alf1=alp(itypi)
14466         alf2=alp(itypj)
14467       alf12=0.5D0*(alf1+alf2)
14468         xj=c(1,nres+j)-xi
14469         yj=c(2,nres+j)-yi
14470         zj=c(3,nres+j)-zi
14471         call to_box(xj,yj,zj)
14472       call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14473         aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14474         +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14475         bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14476              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14477             xj=boxshift(xj-xi,boxxsize)
14478             yj=boxshift(yj-yi,boxysize)
14479             zj=boxshift(zj-zi,boxzsize)
14480             dxj=dc_norm(1,nres+j)
14481             dyj=dc_norm(2,nres+j)
14482             dzj=dc_norm(3,nres+j)
14483             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14484             rij=dsqrt(rrij)
14485             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14486
14487             if (sss.gt.0.0d0) then
14488
14489 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
14490               call sc_angular
14491 ! Calculate whole angle-dependent part of epsilon and contributions
14492 ! to its derivatives
14493               fac=(rrij*sigsq)**expon2
14494               e1=fac*fac*aa_aq(itypi,itypj)
14495               e2=fac*bb_aq(itypi,itypj)
14496               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14497               eps2der=evdwij*eps3rt
14498               eps3der=evdwij*eps2rt
14499               evdwij=evdwij*eps2rt*eps3rt
14500               evdw=evdw+evdwij*sss
14501               if (lprn) then
14502               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14503               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14504 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
14505 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14506 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
14507 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
14508 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
14509 !d     &          evdwij
14510               endif
14511 ! Calculate gradient components.
14512               e1=e1*eps1*eps2rt**2*eps3rt**2
14513               fac=-expon*(e1+evdwij)
14514               sigder=fac/sigsq
14515               fac=rrij*fac
14516 ! Calculate radial part of the gradient
14517               gg(1)=xj*fac
14518               gg(2)=yj*fac
14519               gg(3)=zj*fac
14520 ! Calculate the angular part of the gradient and sum add the contributions
14521 ! to the appropriate components of the Cartesian gradient.
14522               call sc_grad_scale(sss)
14523             endif
14524           enddo      ! j
14525         enddo        ! iint
14526       enddo          ! i
14527 !     stop
14528       return
14529       end subroutine ebp_short
14530 !-----------------------------------------------------------------------------
14531       subroutine egb_long(evdw)
14532 !
14533 ! This subroutine calculates the interaction energy of nonbonded side chains
14534 ! assuming the Gay-Berne potential of interaction.
14535 !
14536       use calc_data
14537 !      implicit real*8 (a-h,o-z)
14538 !      include 'DIMENSIONS'
14539 !      include 'COMMON.GEO'
14540 !      include 'COMMON.VAR'
14541 !      include 'COMMON.LOCAL'
14542 !      include 'COMMON.CHAIN'
14543 !      include 'COMMON.DERIV'
14544 !      include 'COMMON.NAMES'
14545 !      include 'COMMON.INTERACT'
14546 !      include 'COMMON.IOUNITS'
14547 !      include 'COMMON.CALC'
14548 !      include 'COMMON.CONTROL'
14549       logical :: lprn
14550 !el local variables
14551       integer :: iint,itypi,itypi1,itypj,subchap
14552       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
14553       real(kind=8) :: sss,e1,e2,evdw,sss_grad
14554       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14555                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14556                     ssgradlipi,ssgradlipj
14557
14558
14559       evdw=0.0D0
14560 !cccc      energy_dec=.false.
14561 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14562       evdw=0.0D0
14563       lprn=.false.
14564 !     if (icall.eq.0) lprn=.false.
14565 !el      ind=0
14566       do i=iatsc_s,iatsc_e
14567         itypi=itype(i,1)
14568         if (itypi.eq.ntyp1) cycle
14569         itypi1=itype(i+1,1)
14570         xi=c(1,nres+i)
14571         yi=c(2,nres+i)
14572         zi=c(3,nres+i)
14573         call to_box(xi,yi,zi)
14574         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14575         dxi=dc_norm(1,nres+i)
14576         dyi=dc_norm(2,nres+i)
14577         dzi=dc_norm(3,nres+i)
14578 !        dsci_inv=dsc_inv(itypi)
14579         dsci_inv=vbld_inv(i+nres)
14580 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
14581 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
14582 !
14583 ! Calculate SC interaction energy.
14584 !
14585         do iint=1,nint_gr(i)
14586           do j=istart(i,iint),iend(i,iint)
14587             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14588 !              call dyn_ssbond_ene(i,j,evdwij)
14589 !              evdw=evdw+evdwij
14590 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14591 !                              'evdw',i,j,evdwij,' ss'
14592 !              if (energy_dec) write (iout,*) &
14593 !                              'evdw',i,j,evdwij,' ss'
14594 !             do k=j+1,iend(i,iint)
14595 !C search over all next residues
14596 !              if (dyn_ss_mask(k)) then
14597 !C check if they are cysteins
14598 !C              write(iout,*) 'k=',k
14599
14600 !c              write(iout,*) "PRZED TRI", evdwij
14601 !               evdwij_przed_tri=evdwij
14602 !              call triple_ssbond_ene(i,j,k,evdwij)
14603 !c               if(evdwij_przed_tri.ne.evdwij) then
14604 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14605 !c               endif
14606
14607 !c              write(iout,*) "PO TRI", evdwij
14608 !C call the energy function that removes the artifical triple disulfide
14609 !C bond the soubroutine is located in ssMD.F
14610 !              evdw=evdw+evdwij
14611               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14612                             'evdw',i,j,evdwij,'tss'
14613 !              endif!dyn_ss_mask(k)
14614 !             enddo! k
14615
14616             ELSE
14617 !el            ind=ind+1
14618             itypj=itype(j,1)
14619             if (itypj.eq.ntyp1) cycle
14620 !            dscj_inv=dsc_inv(itypj)
14621             dscj_inv=vbld_inv(j+nres)
14622 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14623 !     &       1.0d0/vbld(j+nres)
14624 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14625             sig0ij=sigma(itypi,itypj)
14626             chi1=chi(itypi,itypj)
14627             chi2=chi(itypj,itypi)
14628             chi12=chi1*chi2
14629             chip1=chip(itypi)
14630             chip2=chip(itypj)
14631             chip12=chip1*chip2
14632             alf1=alp(itypi)
14633             alf2=alp(itypj)
14634             alf12=0.5D0*(alf1+alf2)
14635             xj=c(1,nres+j)
14636             yj=c(2,nres+j)
14637             zj=c(3,nres+j)
14638 ! Searching for nearest neighbour
14639             call to_box(xj,yj,zj)
14640             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14641             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14642              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14643             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14644              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14645             xj=boxshift(xj-xi,boxxsize)
14646             yj=boxshift(yj-yi,boxysize)
14647             zj=boxshift(zj-zi,boxzsize)
14648             dxj=dc_norm(1,nres+j)
14649             dyj=dc_norm(2,nres+j)
14650             dzj=dc_norm(3,nres+j)
14651             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14652             rij=dsqrt(rrij)
14653             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14654             sss_ele_cut=sscale_ele(1.0d0/(rij))
14655             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14656             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14657             if (sss_ele_cut.le.0.0) cycle
14658             if (sss.lt.1.0d0) then
14659
14660 ! Calculate angle-dependent terms of energy and contributions to their
14661 ! derivatives.
14662               call sc_angular
14663               sigsq=1.0D0/sigsq
14664               sig=sig0ij*dsqrt(sigsq)
14665               rij_shift=1.0D0/rij-sig+sig0ij
14666 ! for diagnostics; uncomment
14667 !              rij_shift=1.2*sig0ij
14668 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14669               if (rij_shift.le.0.0D0) then
14670                 evdw=1.0D20
14671 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14672 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14673 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14674                 return
14675               endif
14676               sigder=-sig*sigsq
14677 !---------------------------------------------------------------
14678               rij_shift=1.0D0/rij_shift
14679               fac=rij_shift**expon
14680               e1=fac*fac*aa
14681               e2=fac*bb
14682               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14683               eps2der=evdwij*eps3rt
14684               eps3der=evdwij*eps2rt
14685 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14686 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14687               evdwij=evdwij*eps2rt*eps3rt
14688               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
14689               if (lprn) then
14690               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14691               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14692               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14693                 restyp(itypi,1),i,restyp(itypj,1),j,&
14694                 epsi,sigm,chi1,chi2,chip1,chip2,&
14695                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14696                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14697                 evdwij
14698               endif
14699
14700               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14701                               'evdw',i,j,evdwij
14702 !              if (energy_dec) write (iout,*) &
14703 !                              'evdw',i,j,evdwij,"egb_long"
14704
14705 ! Calculate gradient components.
14706               e1=e1*eps1*eps2rt**2*eps3rt**2
14707               fac=-expon*(e1+evdwij)*rij_shift
14708               sigder=fac*sigder
14709               fac=rij*fac
14710               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14711               *rij-sss_grad/(1.0-sss)*rij  &
14712             /sigmaii(itypi,itypj))
14713 !              fac=0.0d0
14714 ! Calculate the radial part of the gradient
14715               gg(1)=xj*fac
14716               gg(2)=yj*fac
14717               gg(3)=zj*fac
14718 ! Calculate angular part of the gradient.
14719               call sc_grad_scale(1.0d0-sss)
14720             ENDIF    !mask_dyn_ss
14721             endif
14722           enddo      ! j
14723         enddo        ! iint
14724       enddo          ! i
14725 !      write (iout,*) "Number of loop steps in EGB:",ind
14726 !ccc      energy_dec=.false.
14727       return
14728       end subroutine egb_long
14729 !-----------------------------------------------------------------------------
14730       subroutine egb_short(evdw)
14731 !
14732 ! This subroutine calculates the interaction energy of nonbonded side chains
14733 ! assuming the Gay-Berne potential of interaction.
14734 !
14735       use calc_data
14736 !      implicit real*8 (a-h,o-z)
14737 !      include 'DIMENSIONS'
14738 !      include 'COMMON.GEO'
14739 !      include 'COMMON.VAR'
14740 !      include 'COMMON.LOCAL'
14741 !      include 'COMMON.CHAIN'
14742 !      include 'COMMON.DERIV'
14743 !      include 'COMMON.NAMES'
14744 !      include 'COMMON.INTERACT'
14745 !      include 'COMMON.IOUNITS'
14746 !      include 'COMMON.CALC'
14747 !      include 'COMMON.CONTROL'
14748       logical :: lprn
14749 !el local variables
14750       integer :: iint,itypi,itypi1,itypj,subchap
14751       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
14752       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
14753       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14754                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
14755                     ssgradlipi,ssgradlipj
14756       evdw=0.0D0
14757 !cccc      energy_dec=.false.
14758 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14759       evdw=0.0D0
14760       lprn=.false.
14761 !     if (icall.eq.0) lprn=.false.
14762 !el      ind=0
14763       do i=iatsc_s,iatsc_e
14764         itypi=itype(i,1)
14765         if (itypi.eq.ntyp1) cycle
14766         itypi1=itype(i+1,1)
14767         xi=c(1,nres+i)
14768         yi=c(2,nres+i)
14769         zi=c(3,nres+i)
14770         call to_box(xi,yi,zi)
14771         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14772
14773         dxi=dc_norm(1,nres+i)
14774         dyi=dc_norm(2,nres+i)
14775         dzi=dc_norm(3,nres+i)
14776 !        dsci_inv=dsc_inv(itypi)
14777         dsci_inv=vbld_inv(i+nres)
14778
14779         dxi=dc_norm(1,nres+i)
14780         dyi=dc_norm(2,nres+i)
14781         dzi=dc_norm(3,nres+i)
14782 !        dsci_inv=dsc_inv(itypi)
14783         dsci_inv=vbld_inv(i+nres)
14784         do iint=1,nint_gr(i)
14785           do j=istart(i,iint),iend(i,iint)
14786             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
14787               call dyn_ssbond_ene(i,j,evdwij)
14788               evdw=evdw+evdwij
14789               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14790                               'evdw',i,j,evdwij,' ss'
14791              do k=j+1,iend(i,iint)
14792 !C search over all next residues
14793               if (dyn_ss_mask(k)) then
14794 !C check if they are cysteins
14795 !C              write(iout,*) 'k=',k
14796
14797 !c              write(iout,*) "PRZED TRI", evdwij
14798 !               evdwij_przed_tri=evdwij
14799               call triple_ssbond_ene(i,j,k,evdwij)
14800 !c               if(evdwij_przed_tri.ne.evdwij) then
14801 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
14802 !c               endif
14803
14804 !c              write(iout,*) "PO TRI", evdwij
14805 !C call the energy function that removes the artifical triple disulfide
14806 !C bond the soubroutine is located in ssMD.F
14807               evdw=evdw+evdwij
14808               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
14809                             'evdw',i,j,evdwij,'tss'
14810               endif!dyn_ss_mask(k)
14811              enddo! k
14812             ELSE
14813
14814 !          typj=itype(j,1)
14815             if (itypj.eq.ntyp1) cycle
14816 !            dscj_inv=dsc_inv(itypj)
14817             dscj_inv=vbld_inv(j+nres)
14818             dscj_inv=dsc_inv(itypj)
14819 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
14820 !     &       1.0d0/vbld(j+nres)
14821 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
14822             sig0ij=sigma(itypi,itypj)
14823             chi1=chi(itypi,itypj)
14824             chi2=chi(itypj,itypi)
14825             chi12=chi1*chi2
14826             chip1=chip(itypi)
14827             chip2=chip(itypj)
14828             chip12=chip1*chip2
14829             alf1=alp(itypi)
14830             alf2=alp(itypj)
14831             alf12=0.5D0*(alf1+alf2)
14832 !            xj=c(1,nres+j)-xi
14833 !            yj=c(2,nres+j)-yi
14834 !            zj=c(3,nres+j)-zi
14835             xj=c(1,nres+j)
14836             yj=c(2,nres+j)
14837             zj=c(3,nres+j)
14838 ! Searching for nearest neighbour
14839             call to_box(xj,yj,zj)
14840             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
14841             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14842              +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14843             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
14844              +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
14845             xj=boxshift(xj-xi,boxxsize)
14846             yj=boxshift(yj-yi,boxysize)
14847             zj=boxshift(zj-zi,boxzsize)
14848             dxj=dc_norm(1,nres+j)
14849             dyj=dc_norm(2,nres+j)
14850             dzj=dc_norm(3,nres+j)
14851             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14852             rij=dsqrt(rrij)
14853             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14854             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
14855             sss_ele_cut=sscale_ele(1.0d0/(rij))
14856             sss_ele_grad=sscagrad_ele(1.0d0/(rij))
14857             if (sss_ele_cut.le.0.0) cycle
14858
14859             if (sss.gt.0.0d0) then
14860
14861 ! Calculate angle-dependent terms of energy and contributions to their
14862 ! derivatives.
14863               call sc_angular
14864               sigsq=1.0D0/sigsq
14865               sig=sig0ij*dsqrt(sigsq)
14866               rij_shift=1.0D0/rij-sig+sig0ij
14867 ! for diagnostics; uncomment
14868 !              rij_shift=1.2*sig0ij
14869 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14870               if (rij_shift.le.0.0D0) then
14871                 evdw=1.0D20
14872 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
14873 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
14874 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
14875                 return
14876               endif
14877               sigder=-sig*sigsq
14878 !---------------------------------------------------------------
14879               rij_shift=1.0D0/rij_shift
14880               fac=rij_shift**expon
14881               e1=fac*fac*aa
14882               e2=fac*bb
14883               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14884               eps2der=evdwij*eps3rt
14885               eps3der=evdwij*eps2rt
14886 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
14887 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
14888               evdwij=evdwij*eps2rt*eps3rt
14889               evdw=evdw+evdwij*sss*sss_ele_cut
14890               if (lprn) then
14891               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14892               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14893               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14894                 restyp(itypi,1),i,restyp(itypj,1),j,&
14895                 epsi,sigm,chi1,chi2,chip1,chip2,&
14896                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
14897                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14898                 evdwij
14899               endif
14900
14901               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14902                               'evdw',i,j,evdwij
14903 !              if (energy_dec) write (iout,*) &
14904 !                              'evdw',i,j,evdwij,"egb_short"
14905
14906 ! Calculate gradient components.
14907               e1=e1*eps1*eps2rt**2*eps3rt**2
14908               fac=-expon*(e1+evdwij)*rij_shift
14909               sigder=fac*sigder
14910               fac=rij*fac
14911               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
14912             *rij+sss_grad/sss*rij  &
14913             /sigmaii(itypi,itypj))
14914
14915 !              fac=0.0d0
14916 ! Calculate the radial part of the gradient
14917               gg(1)=xj*fac
14918               gg(2)=yj*fac
14919               gg(3)=zj*fac
14920 ! Calculate angular part of the gradient.
14921               call sc_grad_scale(sss)
14922             endif
14923           ENDIF !mask_dyn_ss
14924           enddo      ! j
14925         enddo        ! iint
14926       enddo          ! i
14927 !      write (iout,*) "Number of loop steps in EGB:",ind
14928 !ccc      energy_dec=.false.
14929       return
14930       end subroutine egb_short
14931 !-----------------------------------------------------------------------------
14932       subroutine egbv_long(evdw)
14933 !
14934 ! This subroutine calculates the interaction energy of nonbonded side chains
14935 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14936 !
14937       use calc_data
14938 !      implicit real*8 (a-h,o-z)
14939 !      include 'DIMENSIONS'
14940 !      include 'COMMON.GEO'
14941 !      include 'COMMON.VAR'
14942 !      include 'COMMON.LOCAL'
14943 !      include 'COMMON.CHAIN'
14944 !      include 'COMMON.DERIV'
14945 !      include 'COMMON.NAMES'
14946 !      include 'COMMON.INTERACT'
14947 !      include 'COMMON.IOUNITS'
14948 !      include 'COMMON.CALC'
14949       use comm_srutu
14950 !el      integer :: icall
14951 !el      common /srutu/ icall
14952       logical :: lprn
14953 !el local variables
14954       integer :: iint,itypi,itypi1,itypj
14955       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij,&
14956                       sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
14957       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
14958       evdw=0.0D0
14959 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14960       evdw=0.0D0
14961       lprn=.false.
14962 !     if (icall.eq.0) lprn=.true.
14963 !el      ind=0
14964       do i=iatsc_s,iatsc_e
14965         itypi=itype(i,1)
14966         if (itypi.eq.ntyp1) cycle
14967         itypi1=itype(i+1,1)
14968         xi=c(1,nres+i)
14969         yi=c(2,nres+i)
14970         zi=c(3,nres+i)
14971         call to_box(xi,yi,zi)
14972         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
14973         dxi=dc_norm(1,nres+i)
14974         dyi=dc_norm(2,nres+i)
14975         dzi=dc_norm(3,nres+i)
14976
14977 !        dsci_inv=dsc_inv(itypi)
14978         dsci_inv=vbld_inv(i+nres)
14979 !
14980 ! Calculate SC interaction energy.
14981 !
14982         do iint=1,nint_gr(i)
14983           do j=istart(i,iint),iend(i,iint)
14984 !el            ind=ind+1
14985             itypj=itype(j,1)
14986             if (itypj.eq.ntyp1) cycle
14987 !            dscj_inv=dsc_inv(itypj)
14988             dscj_inv=vbld_inv(j+nres)
14989             sig0ij=sigma(itypi,itypj)
14990             r0ij=r0(itypi,itypj)
14991             chi1=chi(itypi,itypj)
14992             chi2=chi(itypj,itypi)
14993             chi12=chi1*chi2
14994             chip1=chip(itypi)
14995             chip2=chip(itypj)
14996             chip12=chip1*chip2
14997             alf1=alp(itypi)
14998             alf2=alp(itypj)
14999             alf12=0.5D0*(alf1+alf2)
15000             xj=c(1,nres+j)-xi
15001             yj=c(2,nres+j)-yi
15002             zj=c(3,nres+j)-zi
15003             call to_box(xj,yj,zj)
15004             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15005             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15006             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15007             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15008             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15009             xj=boxshift(xj-xi,boxxsize)
15010             yj=boxshift(yj-yi,boxysize)
15011             zj=boxshift(zj-zi,boxzsize)
15012             dxj=dc_norm(1,nres+j)
15013             dyj=dc_norm(2,nres+j)
15014             dzj=dc_norm(3,nres+j)
15015             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15016             rij=dsqrt(rrij)
15017
15018             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
15019
15020             if (sss.lt.1.0d0) then
15021
15022 ! Calculate angle-dependent terms of energy and contributions to their
15023 ! derivatives.
15024               call sc_angular
15025               sigsq=1.0D0/sigsq
15026               sig=sig0ij*dsqrt(sigsq)
15027               rij_shift=1.0D0/rij-sig+r0ij
15028 ! I hate to put IF's in the loops, but here don't have another choice!!!!
15029               if (rij_shift.le.0.0D0) then
15030                 evdw=1.0D20
15031                 return
15032               endif
15033               sigder=-sig*sigsq
15034 !---------------------------------------------------------------
15035               rij_shift=1.0D0/rij_shift
15036               fac=rij_shift**expon
15037               e1=fac*fac*aa_aq(itypi,itypj)
15038               e2=fac*bb_aq(itypi,itypj)
15039               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
15040               eps2der=evdwij*eps3rt
15041               eps3der=evdwij*eps2rt
15042               fac_augm=rrij**expon
15043               e_augm=augm(itypi,itypj)*fac_augm
15044               evdwij=evdwij*eps2rt*eps3rt
15045               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
15046               if (lprn) then
15047               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
15048               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
15049               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
15050                 restyp(itypi,1),i,restyp(itypj,1),j,&
15051                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
15052                 chi1,chi2,chip1,chip2,&
15053                 eps1,eps2rt**2,eps3rt**2,&
15054                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
15055                 evdwij+e_augm
15056               endif
15057 ! Calculate gradient components.
15058               e1=e1*eps1*eps2rt**2*eps3rt**2
15059               fac=-expon*(e1+evdwij)*rij_shift
15060               sigder=fac*sigder
15061               fac=rij*fac-2*expon*rrij*e_augm
15062 ! Calculate the radial part of the gradient
15063               gg(1)=xj*fac
15064               gg(2)=yj*fac
15065               gg(3)=zj*fac
15066 ! Calculate angular part of the gradient.
15067               call sc_grad_scale(1.0d0-sss)
15068             endif
15069           enddo      ! j
15070         enddo        ! iint
15071       enddo          ! i
15072       end subroutine egbv_long
15073 !-----------------------------------------------------------------------------
15074       subroutine egbv_short(evdw)
15075 !
15076 ! This subroutine calculates the interaction energy of nonbonded side chains
15077 ! assuming the Gay-Berne-Vorobjev potential of interaction.
15078 !
15079       use calc_data
15080 !      implicit real*8 (a-h,o-z)
15081 !      include 'DIMENSIONS'
15082 !      include 'COMMON.GEO'
15083 !      include 'COMMON.VAR'
15084 !      include 'COMMON.LOCAL'
15085 !      include 'COMMON.CHAIN'
15086 !      include 'COMMON.DERIV'
15087 !      include 'COMMON.NAMES'
15088 !      include 'COMMON.INTERACT'
15089 !      include 'COMMON.IOUNITS'
15090 !      include 'COMMON.CALC'
15091       use comm_srutu
15092 !el      integer :: icall
15093 !el      common /srutu/ icall
15094       logical :: lprn
15095 !el local variables
15096       integer :: iint,itypi,itypi1,itypj
15097       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift,&
15098                       sslipi,ssgradlipi, sslipj,ssgradlipj,aa,bb
15099       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
15100       evdw=0.0D0
15101 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
15102       evdw=0.0D0
15103       lprn=.false.
15104 !     if (icall.eq.0) lprn=.true.
15105 !el      ind=0
15106       do i=iatsc_s,iatsc_e
15107         itypi=itype(i,1)
15108         if (itypi.eq.ntyp1) cycle
15109         itypi1=itype(i+1,1)
15110         xi=c(1,nres+i)
15111         yi=c(2,nres+i)
15112         zi=c(3,nres+i)
15113         dxi=dc_norm(1,nres+i)
15114         dyi=dc_norm(2,nres+i)
15115         dzi=dc_norm(3,nres+i)
15116         call to_box(xi,yi,zi)
15117         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
15118 !        dsci_inv=dsc_inv(itypi)
15119         dsci_inv=vbld_inv(i+nres)
15120 !
15121 ! Calculate SC interaction energy.
15122 !
15123         do iint=1,nint_gr(i)
15124           do j=istart(i,iint),iend(i,iint)
15125 !el            ind=ind+1
15126             itypj=itype(j,1)
15127             if (itypj.eq.ntyp1) cycle
15128 !            dscj_inv=dsc_inv(itypj)
15129             dscj_inv=vbld_inv(j+nres)
15130             sig0ij=sigma(itypi,itypj)
15131             r0ij=r0(itypi,itypj)
15132             chi1=chi(itypi,itypj)
15133             chi2=chi(itypj,itypi)
15134             chi12=chi1*chi2
15135             chip1=chip(itypi)
15136             chip2=chip(itypj)
15137             chip12=chip1*chip2
15138             alf1=alp(itypi)
15139             alf2=alp(itypj)
15140             alf12=0.5D0*(alf1+alf2)
15141             xj=c(1,nres+j)-xi
15142             yj=c(2,nres+j)-yi
15143             zj=c(3,nres+j)-zi
15144             call to_box(xj,yj,zj)
15145             call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15146             aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15147             +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15148             bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
15149             +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
15150             xj=boxshift(xj-xi,boxxsize)
15151             yj=boxshift(yj-yi,boxysize)
15152             zj=boxshift(zj-zi,boxzsize)
15153             dxj=dc_norm(1,nres+j)
15154             dyj=dc_norm(2,nres+j)
15155             dzj=dc_norm(3,nres+j)
15156             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15157             rij=dsqrt(rrij)
15158
15159             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
15160
15161             if (sss.gt.0.0d0) then
15162
15163 ! Calculate angle-dependent terms of energy and contributions to their
15164 ! derivatives.
15165               call sc_angular
15166               sigsq=1.0D0/sigsq
15167               sig=sig0ij*dsqrt(sigsq)
15168               rij_shift=1.0D0/rij-sig+r0ij
15169 ! I hate to put IF's in the loops, but here don't have another choice!!!!
15170               if (rij_shift.le.0.0D0) then
15171                 evdw=1.0D20
15172                 return
15173               endif
15174               sigder=-sig*sigsq
15175 !---------------------------------------------------------------
15176               rij_shift=1.0D0/rij_shift
15177               fac=rij_shift**expon
15178               e1=fac*fac*aa_aq(itypi,itypj)
15179               e2=fac*bb_aq(itypi,itypj)
15180               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
15181               eps2der=evdwij*eps3rt
15182               eps3der=evdwij*eps2rt
15183               fac_augm=rrij**expon
15184               e_augm=augm(itypi,itypj)*fac_augm
15185               evdwij=evdwij*eps2rt*eps3rt
15186               evdw=evdw+(evdwij+e_augm)*sss
15187               if (lprn) then
15188               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
15189               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
15190               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
15191                 restyp(itypi,1),i,restyp(itypj,1),j,&
15192                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
15193                 chi1,chi2,chip1,chip2,&
15194                 eps1,eps2rt**2,eps3rt**2,&
15195                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
15196                 evdwij+e_augm
15197               endif
15198 ! Calculate gradient components.
15199               e1=e1*eps1*eps2rt**2*eps3rt**2
15200               fac=-expon*(e1+evdwij)*rij_shift
15201               sigder=fac*sigder
15202               fac=rij*fac-2*expon*rrij*e_augm
15203 ! Calculate the radial part of the gradient
15204               gg(1)=xj*fac
15205               gg(2)=yj*fac
15206               gg(3)=zj*fac
15207 ! Calculate angular part of the gradient.
15208               call sc_grad_scale(sss)
15209             endif
15210           enddo      ! j
15211         enddo        ! iint
15212       enddo          ! i
15213       end subroutine egbv_short
15214 !-----------------------------------------------------------------------------
15215       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15216 !
15217 ! This subroutine calculates the average interaction energy and its gradient
15218 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
15219 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
15220 ! The potential depends both on the distance of peptide-group centers and on
15221 ! the orientation of the CA-CA virtual bonds.
15222 !
15223 !      implicit real*8 (a-h,o-z)
15224
15225       use comm_locel
15226 #ifdef MPI
15227       include 'mpif.h'
15228 #endif
15229 !      include 'DIMENSIONS'
15230 !      include 'COMMON.CONTROL'
15231 !      include 'COMMON.SETUP'
15232 !      include 'COMMON.IOUNITS'
15233 !      include 'COMMON.GEO'
15234 !      include 'COMMON.VAR'
15235 !      include 'COMMON.LOCAL'
15236 !      include 'COMMON.CHAIN'
15237 !      include 'COMMON.DERIV'
15238 !      include 'COMMON.INTERACT'
15239 !      include 'COMMON.CONTACTS'
15240 !      include 'COMMON.TORSION'
15241 !      include 'COMMON.VECTORS'
15242 !      include 'COMMON.FFIELD'
15243 !      include 'COMMON.TIME1'
15244       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
15245       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
15246       real(kind=8),dimension(2,2) :: acipa !el,a_temp
15247 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
15248       real(kind=8),dimension(4) :: muij
15249 !el      integer :: num_conti,j1,j2
15250 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
15251 !el                   dz_normi,xmedi,ymedi,zmedi
15252 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
15253 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15254 !el          num_conti,j1,j2
15255 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15256 #ifdef MOMENT
15257       real(kind=8) :: scal_el=1.0d0
15258 #else
15259       real(kind=8) :: scal_el=0.5d0
15260 #endif
15261 ! 12/13/98
15262 ! 13-go grudnia roku pamietnego...
15263       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
15264                                              0.0d0,1.0d0,0.0d0,&
15265                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
15266 !el local variables
15267       integer :: i,j,k
15268       real(kind=8) :: fac
15269       real(kind=8) :: dxj,dyj,dzj
15270       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
15271
15272 !      allocate(num_cont_hb(nres)) !(maxres)
15273 !d      write(iout,*) 'In EELEC'
15274 !d      do i=1,nloctyp
15275 !d        write(iout,*) 'Type',i
15276 !d        write(iout,*) 'B1',B1(:,i)
15277 !d        write(iout,*) 'B2',B2(:,i)
15278 !d        write(iout,*) 'CC',CC(:,:,i)
15279 !d        write(iout,*) 'DD',DD(:,:,i)
15280 !d        write(iout,*) 'EE',EE(:,:,i)
15281 !d      enddo
15282 !d      call check_vecgrad
15283 !d      stop
15284       if (icheckgrad.eq.1) then
15285         do i=1,nres-1
15286           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
15287           do k=1,3
15288             dc_norm(k,i)=dc(k,i)*fac
15289           enddo
15290 !          write (iout,*) 'i',i,' fac',fac
15291         enddo
15292       endif
15293       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15294           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
15295           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
15296 !        call vec_and_deriv
15297 #ifdef TIMING
15298         time01=MPI_Wtime()
15299 #endif
15300 !        print *, "before set matrices"
15301         call set_matrices
15302 !        print *,"after set martices"
15303 #ifdef TIMING
15304         time_mat=time_mat+MPI_Wtime()-time01
15305 #endif
15306       endif
15307 !d      do i=1,nres-1
15308 !d        write (iout,*) 'i=',i
15309 !d        do k=1,3
15310 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
15311 !d        enddo
15312 !d        do k=1,3
15313 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
15314 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
15315 !d        enddo
15316 !d      enddo
15317       t_eelecij=0.0d0
15318       ees=0.0D0
15319       evdw1=0.0D0
15320       eel_loc=0.0d0
15321       eello_turn3=0.0d0
15322       eello_turn4=0.0d0
15323 !el      ind=0
15324       do i=1,nres
15325         num_cont_hb(i)=0
15326       enddo
15327 !d      print '(a)','Enter EELEC'
15328 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
15329 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
15330 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
15331       do i=1,nres
15332         gel_loc_loc(i)=0.0d0
15333         gcorr_loc(i)=0.0d0
15334       enddo
15335 !
15336 !
15337 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
15338 !
15339 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
15340 !
15341       do i=iturn3_start,iturn3_end
15342         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
15343         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
15344         dxi=dc(1,i)
15345         dyi=dc(2,i)
15346         dzi=dc(3,i)
15347         dx_normi=dc_norm(1,i)
15348         dy_normi=dc_norm(2,i)
15349         dz_normi=dc_norm(3,i)
15350         xmedi=c(1,i)+0.5d0*dxi
15351         ymedi=c(2,i)+0.5d0*dyi
15352         zmedi=c(3,i)+0.5d0*dzi
15353         call to_box(xmedi,ymedi,zmedi)
15354         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15355         num_conti=0
15356         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
15357         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
15358         num_cont_hb(i)=num_conti
15359       enddo
15360       do i=iturn4_start,iturn4_end
15361         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
15362           .or. itype(i+3,1).eq.ntyp1 &
15363           .or. itype(i+4,1).eq.ntyp1) cycle
15364         dxi=dc(1,i)
15365         dyi=dc(2,i)
15366         dzi=dc(3,i)
15367         dx_normi=dc_norm(1,i)
15368         dy_normi=dc_norm(2,i)
15369         dz_normi=dc_norm(3,i)
15370         xmedi=c(1,i)+0.5d0*dxi
15371         ymedi=c(2,i)+0.5d0*dyi
15372         zmedi=c(3,i)+0.5d0*dzi
15373
15374         call to_box(xmedi,ymedi,zmedi)
15375         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15376
15377         num_conti=num_cont_hb(i)
15378         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
15379         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
15380           call eturn4(i,eello_turn4)
15381         num_cont_hb(i)=num_conti
15382       enddo   ! i
15383 !
15384 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
15385 !
15386       do i=iatel_s,iatel_e
15387         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15388         dxi=dc(1,i)
15389         dyi=dc(2,i)
15390         dzi=dc(3,i)
15391         dx_normi=dc_norm(1,i)
15392         dy_normi=dc_norm(2,i)
15393         dz_normi=dc_norm(3,i)
15394         xmedi=c(1,i)+0.5d0*dxi
15395         ymedi=c(2,i)+0.5d0*dyi
15396         zmedi=c(3,i)+0.5d0*dzi
15397         call to_box(xmedi,ymedi,zmedi)
15398         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
15399 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
15400         num_conti=num_cont_hb(i)
15401         do j=ielstart(i),ielend(i)
15402           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15403           call eelecij_scale(i,j,ees,evdw1,eel_loc)
15404         enddo ! j
15405         num_cont_hb(i)=num_conti
15406       enddo   ! i
15407 !      write (iout,*) "Number of loop steps in EELEC:",ind
15408 !d      do i=1,nres
15409 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
15410 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
15411 !d      enddo
15412 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
15413 !cc      eel_loc=eel_loc+eello_turn3
15414 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
15415       return
15416       end subroutine eelec_scale
15417 !-----------------------------------------------------------------------------
15418       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
15419 !      implicit real*8 (a-h,o-z)
15420
15421       use comm_locel
15422 !      include 'DIMENSIONS'
15423 #ifdef MPI
15424       include "mpif.h"
15425 #endif
15426 !      include 'COMMON.CONTROL'
15427 !      include 'COMMON.IOUNITS'
15428 !      include 'COMMON.GEO'
15429 !      include 'COMMON.VAR'
15430 !      include 'COMMON.LOCAL'
15431 !      include 'COMMON.CHAIN'
15432 !      include 'COMMON.DERIV'
15433 !      include 'COMMON.INTERACT'
15434 !      include 'COMMON.CONTACTS'
15435 !      include 'COMMON.TORSION'
15436 !      include 'COMMON.VECTORS'
15437 !      include 'COMMON.FFIELD'
15438 !      include 'COMMON.TIME1'
15439       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
15440       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
15441       real(kind=8),dimension(2,2) :: acipa !el,a_temp
15442 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
15443       real(kind=8),dimension(4) :: muij
15444       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15445                     dist_temp, dist_init,sss_grad
15446       integer xshift,yshift,zshift
15447
15448 !el      integer :: num_conti,j1,j2
15449 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
15450 !el                   dz_normi,xmedi,ymedi,zmedi
15451 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
15452 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15453 !el          num_conti,j1,j2
15454 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15455 #ifdef MOMENT
15456       real(kind=8) :: scal_el=1.0d0
15457 #else
15458       real(kind=8) :: scal_el=0.5d0
15459 #endif
15460 ! 12/13/98
15461 ! 13-go grudnia roku pamietnego...
15462       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
15463                                              0.0d0,1.0d0,0.0d0,&
15464                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
15465 !el local variables
15466       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
15467       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
15468       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
15469       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
15470       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
15471       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
15472       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
15473                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
15474                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
15475                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
15476                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
15477                   ecosam,ecosbm,ecosgm,ghalf,time00,faclipij,faclipij2
15478 !      integer :: maxconts
15479 !      maxconts = nres/4
15480 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15481 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15482 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15483 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15484 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15485 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15486 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15487 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
15488 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
15489 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
15490 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
15491 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
15492 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
15493
15494 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
15495 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
15496
15497 #ifdef MPI
15498           time00=MPI_Wtime()
15499 #endif
15500 !d      write (iout,*) "eelecij",i,j
15501 !el          ind=ind+1
15502           iteli=itel(i)
15503           itelj=itel(j)
15504           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15505           aaa=app(iteli,itelj)
15506           bbb=bpp(iteli,itelj)
15507           ael6i=ael6(iteli,itelj)
15508           ael3i=ael3(iteli,itelj)
15509           dxj=dc(1,j)
15510           dyj=dc(2,j)
15511           dzj=dc(3,j)
15512           dx_normj=dc_norm(1,j)
15513           dy_normj=dc_norm(2,j)
15514           dz_normj=dc_norm(3,j)
15515 !          xj=c(1,j)+0.5D0*dxj-xmedi
15516 !          yj=c(2,j)+0.5D0*dyj-ymedi
15517 !          zj=c(3,j)+0.5D0*dzj-zmedi
15518           xj=c(1,j)+0.5D0*dxj
15519           yj=c(2,j)+0.5D0*dyj
15520           zj=c(3,j)+0.5D0*dzj
15521           call to_box(xj,yj,zj)
15522           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
15523           faclipij=(sslipi+sslipj)/2.0d0*lipscale+1.0d0
15524           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
15525           xj=boxshift(xj-xmedi,boxxsize)
15526           yj=boxshift(yj-ymedi,boxysize)
15527           zj=boxshift(zj-zmedi,boxzsize)
15528           rij=xj*xj+yj*yj+zj*zj
15529           rrmij=1.0D0/rij
15530           rij=dsqrt(rij)
15531           rmij=1.0D0/rij
15532 ! For extracting the short-range part of Evdwpp
15533           sss=sscale(rij/rpp(iteli,itelj))
15534             sss_ele_cut=sscale_ele(rij)
15535             sss_ele_grad=sscagrad_ele(rij)
15536             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15537 !             sss_ele_cut=1.0d0
15538 !             sss_ele_grad=0.0d0
15539             if (sss_ele_cut.le.0.0) go to 128
15540
15541           r3ij=rrmij*rmij
15542           r6ij=r3ij*r3ij
15543           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
15544           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
15545           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
15546           fac=cosa-3.0D0*cosb*cosg
15547           ev1=aaa*r6ij*r6ij
15548 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15549           if (j.eq.i+2) ev1=scal_el*ev1
15550           ev2=bbb*r6ij
15551           fac3=ael6i*r6ij
15552           fac4=ael3i*r3ij
15553           evdwij=ev1+ev2
15554           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
15555           el2=fac4*fac
15556           eesij=el1+el2
15557 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
15558           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
15559           ees=ees+eesij*sss_ele_cut
15560           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
15561 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
15562 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
15563 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
15564 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
15565
15566           if (energy_dec) then
15567               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15568               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
15569           endif
15570
15571 !
15572 ! Calculate contributions to the Cartesian gradient.
15573 !
15574 #ifdef SPLITELE
15575           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15576           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
15577           fac1=fac
15578           erij(1)=xj*rmij
15579           erij(2)=yj*rmij
15580           erij(3)=zj*rmij
15581 !
15582 ! Radial derivatives. First process both termini of the fragment (i,j)
15583 !
15584           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
15585           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
15586           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
15587 !          do k=1,3
15588 !            ghalf=0.5D0*ggg(k)
15589 !            gelc(k,i)=gelc(k,i)+ghalf
15590 !            gelc(k,j)=gelc(k,j)+ghalf
15591 !          enddo
15592 ! 9/28/08 AL Gradient compotents will be summed only at the end
15593           do k=1,3
15594             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15595             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15596           enddo
15597 !
15598 ! Loop over residues i+1 thru j-1.
15599 !
15600 !grad          do k=i+1,j-1
15601 !grad            do l=1,3
15602 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15603 !grad            enddo
15604 !grad          enddo
15605           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
15606           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15607           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
15608           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15609           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
15610           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15611 !          do k=1,3
15612 !            ghalf=0.5D0*ggg(k)
15613 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
15614 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
15615 !          enddo
15616 ! 9/28/08 AL Gradient compotents will be summed only at the end
15617           do k=1,3
15618             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15619             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15620           enddo
15621 !
15622 ! Loop over residues i+1 thru j-1.
15623 !
15624 !grad          do k=i+1,j-1
15625 !grad            do l=1,3
15626 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
15627 !grad            enddo
15628 !grad          enddo
15629 #else
15630           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
15631           facel=(el1+eesij)*sss_ele_cut
15632           fac1=fac
15633           fac=-3*rrmij*(facvdw+facvdw+facel)
15634           erij(1)=xj*rmij
15635           erij(2)=yj*rmij
15636           erij(3)=zj*rmij
15637 !
15638 ! Radial derivatives. First process both termini of the fragment (i,j)
15639 !
15640           ggg(1)=fac*xj
15641           ggg(2)=fac*yj
15642           ggg(3)=fac*zj
15643 !          do k=1,3
15644 !            ghalf=0.5D0*ggg(k)
15645 !            gelc(k,i)=gelc(k,i)+ghalf
15646 !            gelc(k,j)=gelc(k,j)+ghalf
15647 !          enddo
15648 ! 9/28/08 AL Gradient compotents will be summed only at the end
15649           do k=1,3
15650             gelc_long(k,j)=gelc(k,j)+ggg(k)
15651             gelc_long(k,i)=gelc(k,i)-ggg(k)
15652           enddo
15653 !
15654 ! Loop over residues i+1 thru j-1.
15655 !
15656 !grad          do k=i+1,j-1
15657 !grad            do l=1,3
15658 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15659 !grad            enddo
15660 !grad          enddo
15661 ! 9/28/08 AL Gradient compotents will be summed only at the end
15662           ggg(1)=facvdw*xj
15663           ggg(2)=facvdw*yj
15664           ggg(3)=facvdw*zj
15665           do k=1,3
15666             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15667             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15668           enddo
15669 #endif
15670 !
15671 ! Angular part
15672 !
15673           ecosa=2.0D0*fac3*fac1+fac4
15674           fac4=-3.0D0*fac4
15675           fac3=-6.0D0*fac3
15676           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
15677           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
15678           do k=1,3
15679             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15680             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15681           enddo
15682 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
15683 !d   &          (dcosg(k),k=1,3)
15684           do k=1,3
15685             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
15686           enddo
15687 !          do k=1,3
15688 !            ghalf=0.5D0*ggg(k)
15689 !            gelc(k,i)=gelc(k,i)+ghalf
15690 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
15691 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15692 !            gelc(k,j)=gelc(k,j)+ghalf
15693 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
15694 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15695 !          enddo
15696 !grad          do k=i+1,j-1
15697 !grad            do l=1,3
15698 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
15699 !grad            enddo
15700 !grad          enddo
15701           do k=1,3
15702             gelc(k,i)=gelc(k,i) &
15703                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15704                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
15705                      *sss_ele_cut
15706             gelc(k,j)=gelc(k,j) &
15707                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15708                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15709                      *sss_ele_cut
15710             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
15711             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
15712           enddo
15713           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
15714               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
15715               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15716 !
15717 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
15718 !   energy of a peptide unit is assumed in the form of a second-order
15719 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
15720 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
15721 !   are computed for EVERY pair of non-contiguous peptide groups.
15722 !
15723           if (j.lt.nres-1) then
15724             j1=j+1
15725             j2=j-1
15726           else
15727             j1=j-1
15728             j2=j-2
15729           endif
15730           kkk=0
15731           do k=1,2
15732             do l=1,2
15733               kkk=kkk+1
15734               muij(kkk)=mu(k,i)*mu(l,j)
15735             enddo
15736           enddo
15737 !d         write (iout,*) 'EELEC: i',i,' j',j
15738 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
15739 !d          write(iout,*) 'muij',muij
15740           ury=scalar(uy(1,i),erij)
15741           urz=scalar(uz(1,i),erij)
15742           vry=scalar(uy(1,j),erij)
15743           vrz=scalar(uz(1,j),erij)
15744           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
15745           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
15746           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
15747           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
15748           fac=dsqrt(-ael6i)*r3ij
15749           a22=a22*fac
15750           a23=a23*fac
15751           a32=a32*fac
15752           a33=a33*fac
15753 !d          write (iout,'(4i5,4f10.5)')
15754 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
15755 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
15756 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
15757 !d     &      uy(:,j),uz(:,j)
15758 !d          write (iout,'(4f10.5)')
15759 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
15760 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
15761 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
15762 !d           write (iout,'(9f10.5/)')
15763 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
15764 ! Derivatives of the elements of A in virtual-bond vectors
15765           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
15766           do k=1,3
15767             uryg(k,1)=scalar(erder(1,k),uy(1,i))
15768             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
15769             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
15770             urzg(k,1)=scalar(erder(1,k),uz(1,i))
15771             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
15772             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
15773             vryg(k,1)=scalar(erder(1,k),uy(1,j))
15774             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
15775             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
15776             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
15777             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
15778             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
15779           enddo
15780 ! Compute radial contributions to the gradient
15781           facr=-3.0d0*rrmij
15782           a22der=a22*facr
15783           a23der=a23*facr
15784           a32der=a32*facr
15785           a33der=a33*facr
15786           agg(1,1)=a22der*xj
15787           agg(2,1)=a22der*yj
15788           agg(3,1)=a22der*zj
15789           agg(1,2)=a23der*xj
15790           agg(2,2)=a23der*yj
15791           agg(3,2)=a23der*zj
15792           agg(1,3)=a32der*xj
15793           agg(2,3)=a32der*yj
15794           agg(3,3)=a32der*zj
15795           agg(1,4)=a33der*xj
15796           agg(2,4)=a33der*yj
15797           agg(3,4)=a33der*zj
15798 ! Add the contributions coming from er
15799           fac3=-3.0d0*fac
15800           do k=1,3
15801             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
15802             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
15803             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
15804             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
15805           enddo
15806           do k=1,3
15807 ! Derivatives in DC(i)
15808 !grad            ghalf1=0.5d0*agg(k,1)
15809 !grad            ghalf2=0.5d0*agg(k,2)
15810 !grad            ghalf3=0.5d0*agg(k,3)
15811 !grad            ghalf4=0.5d0*agg(k,4)
15812             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
15813             -3.0d0*uryg(k,2)*vry)!+ghalf1
15814             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
15815             -3.0d0*uryg(k,2)*vrz)!+ghalf2
15816             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
15817             -3.0d0*urzg(k,2)*vry)!+ghalf3
15818             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
15819             -3.0d0*urzg(k,2)*vrz)!+ghalf4
15820 ! Derivatives in DC(i+1)
15821             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
15822             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
15823             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
15824             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
15825             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
15826             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
15827             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
15828             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
15829 ! Derivatives in DC(j)
15830             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
15831             -3.0d0*vryg(k,2)*ury)!+ghalf1
15832             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
15833             -3.0d0*vrzg(k,2)*ury)!+ghalf2
15834             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
15835             -3.0d0*vryg(k,2)*urz)!+ghalf3
15836             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
15837             -3.0d0*vrzg(k,2)*urz)!+ghalf4
15838 ! Derivatives in DC(j+1) or DC(nres-1)
15839             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
15840             -3.0d0*vryg(k,3)*ury)
15841             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
15842             -3.0d0*vrzg(k,3)*ury)
15843             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
15844             -3.0d0*vryg(k,3)*urz)
15845             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
15846             -3.0d0*vrzg(k,3)*urz)
15847 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
15848 !grad              do l=1,4
15849 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
15850 !grad              enddo
15851 !grad            endif
15852           enddo
15853           acipa(1,1)=a22
15854           acipa(1,2)=a23
15855           acipa(2,1)=a32
15856           acipa(2,2)=a33
15857           a22=-a22
15858           a23=-a23
15859           do l=1,2
15860             do k=1,3
15861               agg(k,l)=-agg(k,l)
15862               aggi(k,l)=-aggi(k,l)
15863               aggi1(k,l)=-aggi1(k,l)
15864               aggj(k,l)=-aggj(k,l)
15865               aggj1(k,l)=-aggj1(k,l)
15866             enddo
15867           enddo
15868           if (j.lt.nres-1) then
15869             a22=-a22
15870             a32=-a32
15871             do l=1,3,2
15872               do k=1,3
15873                 agg(k,l)=-agg(k,l)
15874                 aggi(k,l)=-aggi(k,l)
15875                 aggi1(k,l)=-aggi1(k,l)
15876                 aggj(k,l)=-aggj(k,l)
15877                 aggj1(k,l)=-aggj1(k,l)
15878               enddo
15879             enddo
15880           else
15881             a22=-a22
15882             a23=-a23
15883             a32=-a32
15884             a33=-a33
15885             do l=1,4
15886               do k=1,3
15887                 agg(k,l)=-agg(k,l)
15888                 aggi(k,l)=-aggi(k,l)
15889                 aggi1(k,l)=-aggi1(k,l)
15890                 aggj(k,l)=-aggj(k,l)
15891                 aggj1(k,l)=-aggj1(k,l)
15892               enddo
15893             enddo
15894           endif
15895           ENDIF ! WCORR
15896           IF (wel_loc.gt.0.0d0) THEN
15897 ! Contribution to the local-electrostatic energy coming from the i-j pair
15898           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
15899            +a33*muij(4)
15900 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
15901 !           print *,"EELLOC",i,gel_loc_loc(i-1)
15902           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
15903                   'eelloc',i,j,eel_loc_ij
15904 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
15905
15906           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
15907 ! Partial derivatives in virtual-bond dihedral angles gamma
15908           if (i.gt.1) &
15909           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
15910                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
15911                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
15912                  *sss_ele_cut
15913           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
15914                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
15915                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
15916                  *sss_ele_cut
15917            xtemp(1)=xj
15918            xtemp(2)=yj
15919            xtemp(3)=zj
15920
15921 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
15922           do l=1,3
15923             ggg(l)=(agg(l,1)*muij(1)+ &
15924                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
15925             *sss_ele_cut &
15926              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
15927
15928             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
15929             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
15930 !grad            ghalf=0.5d0*ggg(l)
15931 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
15932 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
15933           enddo
15934 !grad          do k=i+1,j2
15935 !grad            do l=1,3
15936 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
15937 !grad            enddo
15938 !grad          enddo
15939 ! Remaining derivatives of eello
15940           do l=1,3
15941             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
15942                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
15943             *sss_ele_cut
15944
15945             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
15946                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
15947             *sss_ele_cut
15948
15949             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
15950                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
15951             *sss_ele_cut
15952
15953             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
15954                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
15955             *sss_ele_cut
15956
15957           enddo
15958           ENDIF
15959 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
15960 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
15961           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
15962              .and. num_conti.le.maxconts) then
15963 !            write (iout,*) i,j," entered corr"
15964 !
15965 ! Calculate the contact function. The ith column of the array JCONT will
15966 ! contain the numbers of atoms that make contacts with the atom I (of numbers
15967 ! greater than I). The arrays FACONT and GACONT will contain the values of
15968 ! the contact function and its derivative.
15969 !           r0ij=1.02D0*rpp(iteli,itelj)
15970 !           r0ij=1.11D0*rpp(iteli,itelj)
15971             r0ij=2.20D0*rpp(iteli,itelj)
15972 !           r0ij=1.55D0*rpp(iteli,itelj)
15973             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
15974 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15975             if (fcont.gt.0.0D0) then
15976               num_conti=num_conti+1
15977               if (num_conti.gt.maxconts) then
15978 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
15979                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
15980                                ' will skip next contacts for this conf.',num_conti
15981               else
15982                 jcont_hb(num_conti,i)=j
15983 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
15984 !d     &           " jcont_hb",jcont_hb(num_conti,i)
15985                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
15986                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
15987 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
15988 !  terms.
15989                 d_cont(num_conti,i)=rij
15990 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
15991 !     --- Electrostatic-interaction matrix ---
15992                 a_chuj(1,1,num_conti,i)=a22
15993                 a_chuj(1,2,num_conti,i)=a23
15994                 a_chuj(2,1,num_conti,i)=a32
15995                 a_chuj(2,2,num_conti,i)=a33
15996 !     --- Gradient of rij
15997                 do kkk=1,3
15998                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
15999                 enddo
16000                 kkll=0
16001                 do k=1,2
16002                   do l=1,2
16003                     kkll=kkll+1
16004                     do m=1,3
16005                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
16006                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
16007                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
16008                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
16009                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
16010                     enddo
16011                   enddo
16012                 enddo
16013                 ENDIF
16014                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
16015 ! Calculate contact energies
16016                 cosa4=4.0D0*cosa
16017                 wij=cosa-3.0D0*cosb*cosg
16018                 cosbg1=cosb+cosg
16019                 cosbg2=cosb-cosg
16020 !               fac3=dsqrt(-ael6i)/r0ij**3
16021                 fac3=dsqrt(-ael6i)*r3ij
16022 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
16023                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
16024                 if (ees0tmp.gt.0) then
16025                   ees0pij=dsqrt(ees0tmp)
16026                 else
16027                   ees0pij=0
16028                 endif
16029 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
16030                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
16031                 if (ees0tmp.gt.0) then
16032                   ees0mij=dsqrt(ees0tmp)
16033                 else
16034                   ees0mij=0
16035                 endif
16036 !               ees0mij=0.0D0
16037                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
16038                      *sss_ele_cut
16039
16040                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
16041                      *sss_ele_cut
16042
16043 ! Diagnostics. Comment out or remove after debugging!
16044 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
16045 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
16046 !               ees0m(num_conti,i)=0.0D0
16047 ! End diagnostics.
16048 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
16049 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
16050 ! Angular derivatives of the contact function
16051                 ees0pij1=fac3/ees0pij
16052                 ees0mij1=fac3/ees0mij
16053                 fac3p=-3.0D0*fac3*rrmij
16054                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
16055                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
16056 !               ees0mij1=0.0D0
16057                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
16058                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
16059                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
16060                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
16061                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
16062                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
16063                 ecosap=ecosa1+ecosa2
16064                 ecosbp=ecosb1+ecosb2
16065                 ecosgp=ecosg1+ecosg2
16066                 ecosam=ecosa1-ecosa2
16067                 ecosbm=ecosb1-ecosb2
16068                 ecosgm=ecosg1-ecosg2
16069 ! Diagnostics
16070 !               ecosap=ecosa1
16071 !               ecosbp=ecosb1
16072 !               ecosgp=ecosg1
16073 !               ecosam=0.0D0
16074 !               ecosbm=0.0D0
16075 !               ecosgm=0.0D0
16076 ! End diagnostics
16077                 facont_hb(num_conti,i)=fcont
16078                 fprimcont=fprimcont/rij
16079 !d              facont_hb(num_conti,i)=1.0D0
16080 ! Following line is for diagnostics.
16081 !d              fprimcont=0.0D0
16082                 do k=1,3
16083                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
16084                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
16085                 enddo
16086                 do k=1,3
16087                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
16088                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
16089                 enddo
16090 !                gggp(1)=gggp(1)+ees0pijp*xj
16091 !                gggp(2)=gggp(2)+ees0pijp*yj
16092 !                gggp(3)=gggp(3)+ees0pijp*zj
16093 !                gggm(1)=gggm(1)+ees0mijp*xj
16094 !                gggm(2)=gggm(2)+ees0mijp*yj
16095 !                gggm(3)=gggm(3)+ees0mijp*zj
16096                 gggp(1)=gggp(1)+ees0pijp*xj &
16097                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
16098                 gggp(2)=gggp(2)+ees0pijp*yj &
16099                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
16100                 gggp(3)=gggp(3)+ees0pijp*zj &
16101                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
16102
16103                 gggm(1)=gggm(1)+ees0mijp*xj &
16104                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
16105
16106                 gggm(2)=gggm(2)+ees0mijp*yj &
16107                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
16108
16109                 gggm(3)=gggm(3)+ees0mijp*zj &
16110                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
16111
16112 ! Derivatives due to the contact function
16113                 gacont_hbr(1,num_conti,i)=fprimcont*xj
16114                 gacont_hbr(2,num_conti,i)=fprimcont*yj
16115                 gacont_hbr(3,num_conti,i)=fprimcont*zj
16116                 do k=1,3
16117 !
16118 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
16119 !          following the change of gradient-summation algorithm.
16120 !
16121 !grad                  ghalfp=0.5D0*gggp(k)
16122 !grad                  ghalfm=0.5D0*gggm(k)
16123 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
16124 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16125 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
16126 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
16127 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16128 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
16129 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
16130 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
16131 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16132 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
16133 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
16134 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16135 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
16136 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
16137                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
16138                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16139                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
16140                      *sss_ele_cut
16141
16142                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
16143                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16144                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
16145                      *sss_ele_cut
16146
16147                   gacontp_hb3(k,num_conti,i)=gggp(k) &
16148                      *sss_ele_cut
16149
16150                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
16151                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
16152                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
16153                      *sss_ele_cut
16154
16155                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
16156                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
16157                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
16158                      *sss_ele_cut
16159
16160                   gacontm_hb3(k,num_conti,i)=gggm(k) &
16161                      *sss_ele_cut
16162
16163                 enddo
16164               ENDIF ! wcorr
16165               endif  ! num_conti.le.maxconts
16166             endif  ! fcont.gt.0
16167           endif    ! j.gt.i+1
16168           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
16169             do k=1,4
16170               do l=1,3
16171                 ghalf=0.5d0*agg(l,k)
16172                 aggi(l,k)=aggi(l,k)+ghalf
16173                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
16174                 aggj(l,k)=aggj(l,k)+ghalf
16175               enddo
16176             enddo
16177             if (j.eq.nres-1 .and. i.lt.j-2) then
16178               do k=1,4
16179                 do l=1,3
16180                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
16181                 enddo
16182               enddo
16183             endif
16184           endif
16185  128      continue
16186 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
16187       return
16188       end subroutine eelecij_scale
16189 !-----------------------------------------------------------------------------
16190       subroutine evdwpp_short(evdw1)
16191 !
16192 ! Compute Evdwpp
16193 !
16194 !      implicit real*8 (a-h,o-z)
16195 !      include 'DIMENSIONS'
16196 !      include 'COMMON.CONTROL'
16197 !      include 'COMMON.IOUNITS'
16198 !      include 'COMMON.GEO'
16199 !      include 'COMMON.VAR'
16200 !      include 'COMMON.LOCAL'
16201 !      include 'COMMON.CHAIN'
16202 !      include 'COMMON.DERIV'
16203 !      include 'COMMON.INTERACT'
16204 !      include 'COMMON.CONTACTS'
16205 !      include 'COMMON.TORSION'
16206 !      include 'COMMON.VECTORS'
16207 !      include 'COMMON.FFIELD'
16208       real(kind=8),dimension(3) :: ggg
16209 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
16210 #ifdef MOMENT
16211       real(kind=8) :: scal_el=1.0d0
16212 #else
16213       real(kind=8) :: scal_el=0.5d0
16214 #endif
16215 !el local variables
16216       integer :: i,j,k,iteli,itelj,num_conti,isubchap
16217       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
16218       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
16219                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
16220                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
16221       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16222                     dist_temp, dist_init,sss_grad,sslipi,ssgradlipi,&
16223                    sslipj,ssgradlipj,faclipij2
16224       integer xshift,yshift,zshift
16225
16226
16227       evdw1=0.0D0
16228 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
16229 !     & " iatel_e_vdw",iatel_e_vdw
16230       call flush(iout)
16231       do i=iatel_s_vdw,iatel_e_vdw
16232         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
16233         dxi=dc(1,i)
16234         dyi=dc(2,i)
16235         dzi=dc(3,i)
16236         dx_normi=dc_norm(1,i)
16237         dy_normi=dc_norm(2,i)
16238         dz_normi=dc_norm(3,i)
16239         xmedi=c(1,i)+0.5d0*dxi
16240         ymedi=c(2,i)+0.5d0*dyi
16241         zmedi=c(3,i)+0.5d0*dzi
16242         call to_box(xmedi,ymedi,zmedi)
16243         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
16244         num_conti=0
16245 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
16246 !     &   ' ielend',ielend_vdw(i)
16247         call flush(iout)
16248         do j=ielstart_vdw(i),ielend_vdw(i)
16249           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
16250 !el          ind=ind+1
16251           iteli=itel(i)
16252           itelj=itel(j)
16253           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
16254           aaa=app(iteli,itelj)
16255           bbb=bpp(iteli,itelj)
16256           dxj=dc(1,j)
16257           dyj=dc(2,j)
16258           dzj=dc(3,j)
16259           dx_normj=dc_norm(1,j)
16260           dy_normj=dc_norm(2,j)
16261           dz_normj=dc_norm(3,j)
16262 !          xj=c(1,j)+0.5D0*dxj-xmedi
16263 !          yj=c(2,j)+0.5D0*dyj-ymedi
16264 !          zj=c(3,j)+0.5D0*dzj-zmedi
16265           xj=c(1,j)+0.5D0*dxj
16266           yj=c(2,j)+0.5D0*dyj
16267           zj=c(3,j)+0.5D0*dzj
16268           call to_box(xj,yj,zj)
16269           call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
16270           faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
16271           xj=boxshift(xj-xmedi,boxxsize)
16272           yj=boxshift(yj-ymedi,boxysize)
16273           zj=boxshift(zj-zmedi,boxzsize)
16274           rij=xj*xj+yj*yj+zj*zj
16275           rrmij=1.0D0/rij
16276           rij=dsqrt(rij)
16277           sss=sscale(rij/rpp(iteli,itelj))
16278             sss_ele_cut=sscale_ele(rij)
16279             sss_ele_grad=sscagrad_ele(rij)
16280             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
16281             if (sss_ele_cut.le.0.0) cycle
16282           if (sss.gt.0.0d0) then
16283             rmij=1.0D0/rij
16284             r3ij=rrmij*rmij
16285             r6ij=r3ij*r3ij
16286             ev1=aaa*r6ij*r6ij
16287 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
16288             if (j.eq.i+2) ev1=scal_el*ev1
16289             ev2=bbb*r6ij
16290             evdwij=ev1+ev2
16291             if (energy_dec) then
16292               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
16293             endif
16294             evdw1=evdw1+evdwij*sss*sss_ele_cut
16295 !
16296 ! Calculate contributions to the Cartesian gradient.
16297 !
16298             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
16299 !            ggg(1)=facvdw*xj
16300 !            ggg(2)=facvdw*yj
16301 !            ggg(3)=facvdw*zj
16302           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
16303           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
16304           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
16305           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
16306           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
16307           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
16308
16309             do k=1,3
16310               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
16311               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
16312             enddo
16313           endif
16314         enddo ! j
16315       enddo   ! i
16316       return
16317       end subroutine evdwpp_short
16318 !-----------------------------------------------------------------------------
16319       subroutine escp_long(evdw2,evdw2_14)
16320 !
16321 ! This subroutine calculates the excluded-volume interaction energy between
16322 ! peptide-group centers and side chains and its gradient in virtual-bond and
16323 ! side-chain vectors.
16324 !
16325 !      implicit real*8 (a-h,o-z)
16326 !      include 'DIMENSIONS'
16327 !      include 'COMMON.GEO'
16328 !      include 'COMMON.VAR'
16329 !      include 'COMMON.LOCAL'
16330 !      include 'COMMON.CHAIN'
16331 !      include 'COMMON.DERIV'
16332 !      include 'COMMON.INTERACT'
16333 !      include 'COMMON.FFIELD'
16334 !      include 'COMMON.IOUNITS'
16335 !      include 'COMMON.CONTROL'
16336       real(kind=8),dimension(3) :: ggg
16337 !el local variables
16338       integer :: i,iint,j,k,iteli,itypj,subchap
16339       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
16340       real(kind=8) :: evdw2,evdw2_14,evdwij
16341       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16342                     dist_temp, dist_init
16343
16344       evdw2=0.0D0
16345       evdw2_14=0.0d0
16346 !d    print '(a)','Enter ESCP'
16347 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16348       do i=iatscp_s,iatscp_e
16349         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16350         iteli=itel(i)
16351         xi=0.5D0*(c(1,i)+c(1,i+1))
16352         yi=0.5D0*(c(2,i)+c(2,i+1))
16353         zi=0.5D0*(c(3,i)+c(3,i+1))
16354         call to_box(xi,yi,zi)
16355         do iint=1,nscp_gr(i)
16356
16357         do j=iscpstart(i,iint),iscpend(i,iint)
16358           itypj=itype(j,1)
16359           if (itypj.eq.ntyp1) cycle
16360 ! Uncomment following three lines for SC-p interactions
16361 !         xj=c(1,nres+j)-xi
16362 !         yj=c(2,nres+j)-yi
16363 !         zj=c(3,nres+j)-zi
16364 ! Uncomment following three lines for Ca-p interactions
16365           xj=c(1,j)
16366           yj=c(2,j)
16367           zj=c(3,j)
16368           call to_box(xj,yj,zj)
16369           xj=boxshift(xj-xi,boxxsize)
16370           yj=boxshift(yj-yi,boxysize)
16371           zj=boxshift(zj-zi,boxzsize)
16372           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16373
16374           rij=dsqrt(1.0d0/rrij)
16375             sss_ele_cut=sscale_ele(rij)
16376             sss_ele_grad=sscagrad_ele(rij)
16377 !            print *,sss_ele_cut,sss_ele_grad,&
16378 !            (rij),r_cut_ele,rlamb_ele
16379             if (sss_ele_cut.le.0.0) cycle
16380           sss=sscale((rij/rscp(itypj,iteli)))
16381           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16382           if (sss.lt.1.0d0) then
16383
16384             fac=rrij**expon2
16385             e1=fac*fac*aad(itypj,iteli)
16386             e2=fac*bad(itypj,iteli)
16387             if (iabs(j-i) .le. 2) then
16388               e1=scal14*e1
16389               e2=scal14*e2
16390               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
16391             endif
16392             evdwij=e1+e2
16393             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
16394             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16395                 'evdw2',i,j,sss,evdwij
16396 !
16397 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16398 !
16399             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
16400             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
16401             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16402             ggg(1)=xj*fac
16403             ggg(2)=yj*fac
16404             ggg(3)=zj*fac
16405 ! Uncomment following three lines for SC-p interactions
16406 !           do k=1,3
16407 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16408 !           enddo
16409 ! Uncomment following line for SC-p interactions
16410 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16411             do k=1,3
16412               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16413               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16414             enddo
16415           endif
16416         enddo
16417
16418         enddo ! iint
16419       enddo ! i
16420       do i=1,nct
16421         do j=1,3
16422           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16423           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16424           gradx_scp(j,i)=expon*gradx_scp(j,i)
16425         enddo
16426       enddo
16427 !******************************************************************************
16428 !
16429 !                              N O T E !!!
16430 !
16431 ! To save time the factor EXPON has been extracted from ALL components
16432 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16433 ! use!
16434 !
16435 !******************************************************************************
16436       return
16437       end subroutine escp_long
16438 !-----------------------------------------------------------------------------
16439       subroutine escp_short(evdw2,evdw2_14)
16440 !
16441 ! This subroutine calculates the excluded-volume interaction energy between
16442 ! peptide-group centers and side chains and its gradient in virtual-bond and
16443 ! side-chain vectors.
16444 !
16445 !      implicit real*8 (a-h,o-z)
16446 !      include 'DIMENSIONS'
16447 !      include 'COMMON.GEO'
16448 !      include 'COMMON.VAR'
16449 !      include 'COMMON.LOCAL'
16450 !      include 'COMMON.CHAIN'
16451 !      include 'COMMON.DERIV'
16452 !      include 'COMMON.INTERACT'
16453 !      include 'COMMON.FFIELD'
16454 !      include 'COMMON.IOUNITS'
16455 !      include 'COMMON.CONTROL'
16456       real(kind=8),dimension(3) :: ggg
16457 !el local variables
16458       integer :: i,iint,j,k,iteli,itypj,subchap
16459       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
16460       real(kind=8) :: evdw2,evdw2_14,evdwij
16461       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
16462                     dist_temp, dist_init
16463
16464       evdw2=0.0D0
16465       evdw2_14=0.0d0
16466 !d    print '(a)','Enter ESCP'
16467 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
16468       do i=iatscp_s,iatscp_e
16469         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
16470         iteli=itel(i)
16471         xi=0.5D0*(c(1,i)+c(1,i+1))
16472         yi=0.5D0*(c(2,i)+c(2,i+1))
16473         zi=0.5D0*(c(3,i)+c(3,i+1))
16474         call to_box(xi,yi,zi)
16475         if (zi.lt.0) zi=zi+boxzsize
16476
16477         do iint=1,nscp_gr(i)
16478
16479         do j=iscpstart(i,iint),iscpend(i,iint)
16480           itypj=itype(j,1)
16481           if (itypj.eq.ntyp1) cycle
16482 ! Uncomment following three lines for SC-p interactions
16483 !         xj=c(1,nres+j)-xi
16484 !         yj=c(2,nres+j)-yi
16485 !         zj=c(3,nres+j)-zi
16486 ! Uncomment following three lines for Ca-p interactions
16487 !          xj=c(1,j)-xi
16488 !          yj=c(2,j)-yi
16489 !          zj=c(3,j)-zi
16490           xj=c(1,j)
16491           yj=c(2,j)
16492           zj=c(3,j)
16493           call to_box(xj,yj,zj)
16494           xj=boxshift(xj-xi,boxxsize)
16495           yj=boxshift(yj-yi,boxysize)
16496           zj=boxshift(zj-zi,boxzsize)
16497           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
16498           rij=dsqrt(1.0d0/rrij)
16499             sss_ele_cut=sscale_ele(rij)
16500             sss_ele_grad=sscagrad_ele(rij)
16501 !            print *,sss_ele_cut,sss_ele_grad,&
16502 !            (rij),r_cut_ele,rlamb_ele
16503             if (sss_ele_cut.le.0.0) cycle
16504           sss=sscale(rij/rscp(itypj,iteli))
16505           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
16506           if (sss.gt.0.0d0) then
16507
16508             fac=rrij**expon2
16509             e1=fac*fac*aad(itypj,iteli)
16510             e2=fac*bad(itypj,iteli)
16511             if (iabs(j-i) .le. 2) then
16512               e1=scal14*e1
16513               e2=scal14*e2
16514               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
16515             endif
16516             evdwij=e1+e2
16517             evdw2=evdw2+evdwij*sss*sss_ele_cut
16518             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
16519                 'evdw2',i,j,sss,evdwij
16520 !
16521 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
16522 !
16523             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
16524             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
16525             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
16526
16527             ggg(1)=xj*fac
16528             ggg(2)=yj*fac
16529             ggg(3)=zj*fac
16530 ! Uncomment following three lines for SC-p interactions
16531 !           do k=1,3
16532 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16533 !           enddo
16534 ! Uncomment following line for SC-p interactions
16535 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
16536             do k=1,3
16537               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
16538               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
16539             enddo
16540           endif
16541         enddo
16542
16543         enddo ! iint
16544       enddo ! i
16545       do i=1,nct
16546         do j=1,3
16547           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
16548           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
16549           gradx_scp(j,i)=expon*gradx_scp(j,i)
16550         enddo
16551       enddo
16552 !******************************************************************************
16553 !
16554 !                              N O T E !!!
16555 !
16556 ! To save time the factor EXPON has been extracted from ALL components
16557 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
16558 ! use!
16559 !
16560 !******************************************************************************
16561       return
16562       end subroutine escp_short
16563 !-----------------------------------------------------------------------------
16564 ! energy_p_new-sep_barrier.F
16565 !-----------------------------------------------------------------------------
16566       subroutine sc_grad_scale(scalfac)
16567 !      implicit real*8 (a-h,o-z)
16568       use calc_data
16569 !      include 'DIMENSIONS'
16570 !      include 'COMMON.CHAIN'
16571 !      include 'COMMON.DERIV'
16572 !      include 'COMMON.CALC'
16573 !      include 'COMMON.IOUNITS'
16574       real(kind=8),dimension(3) :: dcosom1,dcosom2
16575       real(kind=8) :: scalfac
16576 !el local variables
16577 !      integer :: i,j,k,l
16578
16579       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
16580       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
16581       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
16582            -2.0D0*alf12*eps3der+sigder*sigsq_om12
16583 ! diagnostics only
16584 !      eom1=0.0d0
16585 !      eom2=0.0d0
16586 !      eom12=evdwij*eps1_om12
16587 ! end diagnostics
16588 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
16589 !     &  " sigder",sigder
16590 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
16591 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
16592       do k=1,3
16593         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
16594         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
16595       enddo
16596       do k=1,3
16597         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
16598          *sss_ele_cut
16599       enddo
16600 !      write (iout,*) "gg",(gg(k),k=1,3)
16601       do k=1,3
16602         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
16603                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
16604                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
16605                  *sss_ele_cut
16606         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
16607                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
16608                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
16609          *sss_ele_cut
16610 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
16611 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
16612 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
16613 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
16614       enddo
16615 !
16616 ! Calculate the components of the gradient in DC and X
16617 !
16618       do l=1,3
16619         gvdwc(l,i)=gvdwc(l,i)-gg(l)
16620         gvdwc(l,j)=gvdwc(l,j)+gg(l)
16621       enddo
16622       return
16623       end subroutine sc_grad_scale
16624 !-----------------------------------------------------------------------------
16625 ! energy_split-sep.F
16626 !-----------------------------------------------------------------------------
16627       subroutine etotal_long(energia)
16628 !
16629 ! Compute the long-range slow-varying contributions to the energy
16630 !
16631 !      implicit real*8 (a-h,o-z)
16632 !      include 'DIMENSIONS'
16633       use MD_data, only: totT,usampl,eq_time
16634 #ifndef ISNAN
16635       external proc_proc
16636 #ifdef WINPGI
16637 !MS$ATTRIBUTES C ::  proc_proc
16638 #endif
16639 #endif
16640 #ifdef MPI
16641       include "mpif.h"
16642       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
16643 #endif
16644 !      include 'COMMON.SETUP'
16645 !      include 'COMMON.IOUNITS'
16646 !      include 'COMMON.FFIELD'
16647 !      include 'COMMON.DERIV'
16648 !      include 'COMMON.INTERACT'
16649 !      include 'COMMON.SBRIDGE'
16650 !      include 'COMMON.CHAIN'
16651 !      include 'COMMON.VAR'
16652 !      include 'COMMON.LOCAL'
16653 !      include 'COMMON.MD'
16654       real(kind=8),dimension(0:n_ene) :: energia
16655 !el local variables
16656       integer :: i,n_corr,n_corr1,ierror,ierr
16657       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
16658                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
16659                   ecorr,ecorr5,ecorr6,eturn6,time00, ehomology_constr
16660 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
16661 !elwrite(iout,*)"in etotal long"
16662
16663       if (modecalc.eq.12.or.modecalc.eq.14) then
16664 #ifdef MPI
16665 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
16666 #else
16667         call int_from_cart1(.false.)
16668 #endif
16669       endif
16670 !elwrite(iout,*)"in etotal long"
16671       ehomology_constr=0.0d0
16672 #ifdef MPI
16673 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
16674 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16675       call flush(iout)
16676       if (nfgtasks.gt.1) then
16677         time00=MPI_Wtime()
16678 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16679         if (fg_rank.eq.0) then
16680           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
16681 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16682 !          call flush(iout)
16683 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16684 ! FG slaves as WEIGHTS array.
16685           weights_(1)=wsc
16686           weights_(2)=wscp
16687           weights_(3)=welec
16688           weights_(4)=wcorr
16689           weights_(5)=wcorr5
16690           weights_(6)=wcorr6
16691           weights_(7)=wel_loc
16692           weights_(8)=wturn3
16693           weights_(9)=wturn4
16694           weights_(10)=wturn6
16695           weights_(11)=wang
16696           weights_(12)=wscloc
16697           weights_(13)=wtor
16698           weights_(14)=wtor_d
16699           weights_(15)=wstrain
16700           weights_(16)=wvdwpp
16701           weights_(17)=wbond
16702           weights_(18)=scal14
16703           weights_(21)=wsccor
16704 ! FG Master broadcasts the WEIGHTS_ array
16705           call MPI_Bcast(weights_(1),n_ene,&
16706               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16707         else
16708 ! FG slaves receive the WEIGHTS array
16709           call MPI_Bcast(weights(1),n_ene,&
16710               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16711           wsc=weights(1)
16712           wscp=weights(2)
16713           welec=weights(3)
16714           wcorr=weights(4)
16715           wcorr5=weights(5)
16716           wcorr6=weights(6)
16717           wel_loc=weights(7)
16718           wturn3=weights(8)
16719           wturn4=weights(9)
16720           wturn6=weights(10)
16721           wang=weights(11)
16722           wscloc=weights(12)
16723           wtor=weights(13)
16724           wtor_d=weights(14)
16725           wstrain=weights(15)
16726           wvdwpp=weights(16)
16727           wbond=weights(17)
16728           scal14=weights(18)
16729           wsccor=weights(21)
16730         endif
16731         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
16732           king,FG_COMM,IERR)
16733          time_Bcast=time_Bcast+MPI_Wtime()-time00
16734          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
16735 !        call chainbuild_cart
16736 !        call int_from_cart1(.false.)
16737       endif
16738 !      write (iout,*) 'Processor',myrank,
16739 !     &  ' calling etotal_short ipot=',ipot
16740 !      call flush(iout)
16741 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16742 #endif
16743 !d    print *,'nnt=',nnt,' nct=',nct
16744 !
16745 !elwrite(iout,*)"in etotal long"
16746 ! Compute the side-chain and electrostatic interaction energy
16747 !
16748       goto (101,102,103,104,105,106) ipot
16749 ! Lennard-Jones potential.
16750   101 call elj_long(evdw)
16751 !d    print '(a)','Exit ELJ'
16752       goto 107
16753 ! Lennard-Jones-Kihara potential (shifted).
16754   102 call eljk_long(evdw)
16755       goto 107
16756 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16757   103 call ebp_long(evdw)
16758       goto 107
16759 ! Gay-Berne potential (shifted LJ, angular dependence).
16760   104 call egb_long(evdw)
16761       goto 107
16762 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16763   105 call egbv_long(evdw)
16764       goto 107
16765 ! Soft-sphere potential
16766   106 call e_softsphere(evdw)
16767 !
16768 ! Calculate electrostatic (H-bonding) energy of the main chain.
16769 !
16770   107 continue
16771       call vec_and_deriv
16772       if (ipot.lt.6) then
16773 #ifdef SPLITELE
16774          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
16775              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16776              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16777              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16778 #else
16779          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
16780              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
16781              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
16782              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
16783 #endif
16784            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
16785          else
16786             ees=0
16787             evdw1=0
16788             eel_loc=0
16789             eello_turn3=0
16790             eello_turn4=0
16791          endif
16792       else
16793 !        write (iout,*) "Soft-spheer ELEC potential"
16794         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
16795          eello_turn4)
16796       endif
16797 !
16798 ! Calculate excluded-volume interaction energy between peptide groups
16799 ! and side chains.
16800 !
16801       if (ipot.lt.6) then
16802        if(wscp.gt.0d0) then
16803         call escp_long(evdw2,evdw2_14)
16804        else
16805         evdw2=0
16806         evdw2_14=0
16807        endif
16808       else
16809         call escp_soft_sphere(evdw2,evdw2_14)
16810       endif
16811 !
16812 ! 12/1/95 Multi-body terms
16813 !
16814       n_corr=0
16815       n_corr1=0
16816       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
16817           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
16818          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
16819 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
16820 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
16821       else
16822          ecorr=0.0d0
16823          ecorr5=0.0d0
16824          ecorr6=0.0d0
16825          eturn6=0.0d0
16826       endif
16827       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
16828          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
16829       endif
16830 !
16831 ! If performing constraint dynamics, call the constraint energy
16832 !  after the equilibration time
16833       if(usampl.and.totT.gt.eq_time) then
16834          call EconstrQ
16835          call Econstr_back
16836       else
16837          Uconst=0.0d0
16838          Uconst_back=0.0d0
16839       endif
16840 !
16841 ! Sum the energies
16842 !
16843       do i=1,n_ene
16844         energia(i)=0.0d0
16845       enddo
16846       energia(1)=evdw
16847 #ifdef SCP14
16848       energia(2)=evdw2-evdw2_14
16849       energia(18)=evdw2_14
16850 #else
16851       energia(2)=evdw2
16852       energia(18)=0.0d0
16853 #endif
16854 #ifdef SPLITELE
16855       energia(3)=ees
16856       energia(16)=evdw1
16857 #else
16858       energia(3)=ees+evdw1
16859       energia(16)=0.0d0
16860 #endif
16861       energia(4)=ecorr
16862       energia(5)=ecorr5
16863       energia(6)=ecorr6
16864       energia(7)=eel_loc
16865       energia(8)=eello_turn3
16866       energia(9)=eello_turn4
16867       energia(10)=eturn6
16868       energia(20)=Uconst+Uconst_back
16869       energia(51)=ehomology_constr
16870       call sum_energy(energia,.true.)
16871 !      write (iout,*) "Exit ETOTAL_LONG"
16872       call flush(iout)
16873       return
16874       end subroutine etotal_long
16875 !-----------------------------------------------------------------------------
16876       subroutine etotal_short(energia)
16877 !
16878 ! Compute the short-range fast-varying contributions to the energy
16879 !
16880 !      implicit real*8 (a-h,o-z)
16881 !      include 'DIMENSIONS'
16882 #ifndef ISNAN
16883       external proc_proc
16884 #ifdef WINPGI
16885 !MS$ATTRIBUTES C ::  proc_proc
16886 #endif
16887 #endif
16888 #ifdef MPI
16889       include "mpif.h"
16890       integer :: ierror,ierr
16891       real(kind=8),dimension(n_ene) :: weights_
16892       real(kind=8) :: time00
16893 #endif
16894 !      include 'COMMON.SETUP'
16895 !      include 'COMMON.IOUNITS'
16896 !      include 'COMMON.FFIELD'
16897 !      include 'COMMON.DERIV'
16898 !      include 'COMMON.INTERACT'
16899 !      include 'COMMON.SBRIDGE'
16900 !      include 'COMMON.CHAIN'
16901 !      include 'COMMON.VAR'
16902 !      include 'COMMON.LOCAL'
16903       real(kind=8),dimension(0:n_ene) :: energia
16904 !el local variables
16905       integer :: i,nres6
16906       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
16907       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr, &
16908                       ehomology_constr
16909       nres6=6*nres
16910
16911 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
16912 !      call flush(iout)
16913       if (modecalc.eq.12.or.modecalc.eq.14) then
16914 #ifdef MPI
16915         if (fg_rank.eq.0) call int_from_cart1(.false.)
16916 #else
16917         call int_from_cart1(.false.)
16918 #endif
16919       endif
16920 #ifdef MPI
16921 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
16922 !     & " absolute rank",myrank," nfgtasks",nfgtasks
16923 !      call flush(iout)
16924       if (nfgtasks.gt.1) then
16925         time00=MPI_Wtime()
16926 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
16927         if (fg_rank.eq.0) then
16928           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
16929 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
16930 !          call flush(iout)
16931 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
16932 ! FG slaves as WEIGHTS array.
16933           weights_(1)=wsc
16934           weights_(2)=wscp
16935           weights_(3)=welec
16936           weights_(4)=wcorr
16937           weights_(5)=wcorr5
16938           weights_(6)=wcorr6
16939           weights_(7)=wel_loc
16940           weights_(8)=wturn3
16941           weights_(9)=wturn4
16942           weights_(10)=wturn6
16943           weights_(11)=wang
16944           weights_(12)=wscloc
16945           weights_(13)=wtor
16946           weights_(14)=wtor_d
16947           weights_(15)=wstrain
16948           weights_(16)=wvdwpp
16949           weights_(17)=wbond
16950           weights_(18)=scal14
16951           weights_(21)=wsccor
16952 ! FG Master broadcasts the WEIGHTS_ array
16953           call MPI_Bcast(weights_(1),n_ene,&
16954               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16955         else
16956 ! FG slaves receive the WEIGHTS array
16957           call MPI_Bcast(weights(1),n_ene,&
16958               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16959           wsc=weights(1)
16960           wscp=weights(2)
16961           welec=weights(3)
16962           wcorr=weights(4)
16963           wcorr5=weights(5)
16964           wcorr6=weights(6)
16965           wel_loc=weights(7)
16966           wturn3=weights(8)
16967           wturn4=weights(9)
16968           wturn6=weights(10)
16969           wang=weights(11)
16970           wscloc=weights(12)
16971           wtor=weights(13)
16972           wtor_d=weights(14)
16973           wstrain=weights(15)
16974           wvdwpp=weights(16)
16975           wbond=weights(17)
16976           scal14=weights(18)
16977           wsccor=weights(21)
16978         endif
16979 !        write (iout,*),"Processor",myrank," BROADCAST weights"
16980         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
16981           king,FG_COMM,IERR)
16982 !        write (iout,*) "Processor",myrank," BROADCAST c"
16983         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
16984           king,FG_COMM,IERR)
16985 !        write (iout,*) "Processor",myrank," BROADCAST dc"
16986         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
16987           king,FG_COMM,IERR)
16988 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
16989         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
16990           king,FG_COMM,IERR)
16991 !        write (iout,*) "Processor",myrank," BROADCAST theta"
16992         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
16993           king,FG_COMM,IERR)
16994 !        write (iout,*) "Processor",myrank," BROADCAST phi"
16995         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
16996           king,FG_COMM,IERR)
16997 !        write (iout,*) "Processor",myrank," BROADCAST alph"
16998         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
16999           king,FG_COMM,IERR)
17000 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
17001         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
17002           king,FG_COMM,IERR)
17003 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
17004         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
17005           king,FG_COMM,IERR)
17006          time_Bcast=time_Bcast+MPI_Wtime()-time00
17007 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
17008       endif
17009 !      write (iout,*) 'Processor',myrank,
17010 !     &  ' calling etotal_short ipot=',ipot
17011 !      call flush(iout)
17012 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
17013 #endif
17014 !      call int_from_cart1(.false.)
17015 !
17016 ! Compute the side-chain and electrostatic interaction energy
17017 !
17018       goto (101,102,103,104,105,106) ipot
17019 ! Lennard-Jones potential.
17020   101 call elj_short(evdw)
17021 !d    print '(a)','Exit ELJ'
17022       goto 107
17023 ! Lennard-Jones-Kihara potential (shifted).
17024   102 call eljk_short(evdw)
17025       goto 107
17026 ! Berne-Pechukas potential (dilated LJ, angular dependence).
17027   103 call ebp_short(evdw)
17028       goto 107
17029 ! Gay-Berne potential (shifted LJ, angular dependence).
17030   104 call egb_short(evdw)
17031       goto 107
17032 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
17033   105 call egbv_short(evdw)
17034       goto 107
17035 ! Soft-sphere potential - already dealt with in the long-range part
17036   106 evdw=0.0d0
17037 !  106 call e_softsphere_short(evdw)
17038 !
17039 ! Calculate electrostatic (H-bonding) energy of the main chain.
17040 !
17041   107 continue
17042 !
17043 ! Calculate the short-range part of Evdwpp
17044 !
17045       call evdwpp_short(evdw1)
17046 !
17047 ! Calculate the short-range part of ESCp
17048 !
17049       if (ipot.lt.6) then
17050        call escp_short(evdw2,evdw2_14)
17051       endif
17052 !
17053 ! Calculate the bond-stretching energy
17054 !
17055       call ebond(estr)
17056 !
17057 ! Calculate the disulfide-bridge and other energy and the contributions
17058 ! from other distance constraints.
17059       call edis(ehpb)
17060 !
17061 ! Calculate the virtual-bond-angle energy.
17062 !
17063 ! Calculate the SC local energy.
17064 !
17065       call vec_and_deriv
17066       call esc(escloc)
17067 !
17068       if (wang.gt.0d0) then
17069        if (tor_mode.eq.0) then
17070            call ebend(ebe)
17071        else
17072 !C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
17073 !C energy function
17074         call ebend_kcc(ebe)
17075        endif
17076       else
17077           ebe=0.0d0
17078       endif
17079       ethetacnstr=0.0d0
17080       if (with_theta_constr) call etheta_constr(ethetacnstr)
17081
17082 !       write(iout,*) "in etotal afer ebe",ipot
17083
17084 !      print *,"Processor",myrank," computed UB"
17085 !
17086 ! Calculate the SC local energy.
17087 !
17088       call esc(escloc)
17089 !elwrite(iout,*) "in etotal afer esc",ipot
17090 !      print *,"Processor",myrank," computed USC"
17091 !
17092 ! Calculate the virtual-bond torsional energy.
17093 !
17094 !d    print *,'nterm=',nterm
17095 !      if (wtor.gt.0) then
17096 !       call etor(etors,edihcnstr)
17097 !      else
17098 !       etors=0
17099 !       edihcnstr=0
17100 !      endif
17101       if (wtor.gt.0.0d0) then
17102          if (tor_mode.eq.0) then
17103            call etor(etors)
17104           else
17105 !C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
17106 !C energy function
17107         call etor_kcc(etors)
17108          endif
17109       else
17110            etors=0.0d0
17111       endif
17112       edihcnstr=0.0d0
17113       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
17114
17115 ! Calculate the virtual-bond torsional energy.
17116 !
17117 !
17118 ! 6/23/01 Calculate double-torsional energy
17119 !
17120       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
17121       call etor_d(etors_d)
17122       endif
17123 !
17124 ! Homology restraints
17125 !
17126       if (constr_homology.ge.1) then
17127         call e_modeller(ehomology_constr)
17128 !      print *,"tu"
17129       else
17130         ehomology_constr=0.0d0
17131       endif
17132
17133 !
17134 ! 21/5/07 Calculate local sicdechain correlation energy
17135 !
17136       if (wsccor.gt.0.0d0) then
17137        call eback_sc_corr(esccor)
17138       else
17139        esccor=0.0d0
17140       endif
17141 !
17142 ! Put energy components into an array
17143 !
17144       do i=1,n_ene
17145        energia(i)=0.0d0
17146       enddo
17147       energia(1)=evdw
17148 #ifdef SCP14
17149       energia(2)=evdw2-evdw2_14
17150       energia(18)=evdw2_14
17151 #else
17152       energia(2)=evdw2
17153       energia(18)=0.0d0
17154 #endif
17155 #ifdef SPLITELE
17156       energia(16)=evdw1
17157 #else
17158       energia(3)=evdw1
17159 #endif
17160       energia(11)=ebe
17161       energia(12)=escloc
17162       energia(13)=etors
17163       energia(14)=etors_d
17164       energia(15)=ehpb
17165       energia(17)=estr
17166       energia(19)=edihcnstr
17167       energia(21)=esccor
17168       energia(51)=ehomology_constr
17169 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
17170       call flush(iout)
17171       call sum_energy(energia,.true.)
17172 !      write (iout,*) "Exit ETOTAL_SHORT"
17173       call flush(iout)
17174       return
17175       end subroutine etotal_short
17176 !-----------------------------------------------------------------------------
17177 ! gnmr1.f
17178 !-----------------------------------------------------------------------------
17179       real(kind=8) function gnmr1(y,ymin,ymax)
17180 !      implicit none
17181       real(kind=8) :: y,ymin,ymax
17182       real(kind=8) :: wykl=4.0d0
17183       if (y.lt.ymin) then
17184         gnmr1=(ymin-y)**wykl/wykl
17185       else if (y.gt.ymax) then
17186        gnmr1=(y-ymax)**wykl/wykl
17187       else
17188        gnmr1=0.0d0
17189       endif
17190       return
17191       end function gnmr1
17192 !-----------------------------------------------------------------------------
17193       real(kind=8) function gnmr1prim(y,ymin,ymax)
17194 !      implicit none
17195       real(kind=8) :: y,ymin,ymax
17196       real(kind=8) :: wykl=4.0d0
17197       if (y.lt.ymin) then
17198        gnmr1prim=-(ymin-y)**(wykl-1)
17199       else if (y.gt.ymax) then
17200        gnmr1prim=(y-ymax)**(wykl-1)
17201       else
17202        gnmr1prim=0.0d0
17203       endif
17204       return
17205       end function gnmr1prim
17206 !----------------------------------------------------------------------------
17207       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
17208       real(kind=8) y,ymin,ymax,sigma
17209       real(kind=8) wykl /4.0d0/
17210       if (y.lt.ymin) then
17211         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
17212       else if (y.gt.ymax) then
17213        rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
17214       else
17215         rlornmr1=0.0d0
17216       endif
17217       return
17218       end function rlornmr1
17219 !------------------------------------------------------------------------------
17220       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
17221       real(kind=8) y,ymin,ymax,sigma
17222       real(kind=8) wykl /4.0d0/
17223       if (y.lt.ymin) then
17224         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
17225         ((ymin-y)**wykl+sigma**wykl)**2
17226       else if (y.gt.ymax) then
17227          rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
17228         ((y-ymax)**wykl+sigma**wykl)**2
17229       else
17230        rlornmr1prim=0.0d0
17231       endif
17232       return
17233       end function rlornmr1prim
17234
17235       real(kind=8) function harmonic(y,ymax)
17236 !      implicit none
17237       real(kind=8) :: y,ymax
17238       real(kind=8) :: wykl=2.0d0
17239       harmonic=(y-ymax)**wykl
17240       return
17241       end function harmonic
17242 !-----------------------------------------------------------------------------
17243       real(kind=8) function harmonicprim(y,ymax)
17244       real(kind=8) :: y,ymin,ymax
17245       real(kind=8) :: wykl=2.0d0
17246       harmonicprim=(y-ymax)*wykl
17247       return
17248       end function harmonicprim
17249 !-----------------------------------------------------------------------------
17250 ! gradient_p.F
17251 !-----------------------------------------------------------------------------
17252       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
17253
17254       use io_base, only:intout,briefout
17255 !      implicit real*8 (a-h,o-z)
17256 !      include 'DIMENSIONS'
17257 !      include 'COMMON.CHAIN'
17258 !      include 'COMMON.DERIV'
17259 !      include 'COMMON.VAR'
17260 !      include 'COMMON.INTERACT'
17261 !      include 'COMMON.FFIELD'
17262 !      include 'COMMON.MD'
17263 !      include 'COMMON.IOUNITS'
17264       real(kind=8),external :: ufparm
17265       integer :: uiparm(1)
17266       real(kind=8) :: urparm(1)
17267       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
17268       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
17269       integer :: n,nf,ind,ind1,i,k,j
17270 !
17271 ! This subroutine calculates total internal coordinate gradient.
17272 ! Depending on the number of function evaluations, either whole energy
17273 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
17274 ! internal coordinates are reevaluated or only the cartesian-in-internal
17275 ! coordinate derivatives are evaluated. The subroutine was designed to work
17276 ! with SUMSL.
17277 !
17278 !
17279       icg=mod(nf,2)+1
17280
17281 !d      print *,'grad',nf,icg
17282       if (nf-nfl+1) 20,30,40
17283    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
17284 !    write (iout,*) 'grad 20'
17285       if (nf.eq.0) return
17286       goto 40
17287    30 call var_to_geom(n,x)
17288       call chainbuild
17289 !    write (iout,*) 'grad 30'
17290 !
17291 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
17292 !
17293    40 call cartder
17294 !     write (iout,*) 'grad 40'
17295 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
17296 !
17297 ! Convert the Cartesian gradient into internal-coordinate gradient.
17298 !
17299       ind=0
17300       ind1=0
17301       do i=1,nres-2
17302       gthetai=0.0D0
17303       gphii=0.0D0
17304       do j=i+1,nres-1
17305         ind=ind+1
17306 !         ind=indmat(i,j)
17307 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
17308        do k=1,3
17309        gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
17310         enddo
17311         do k=1,3
17312         gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
17313          enddo
17314        enddo
17315       do j=i+1,nres-1
17316         ind1=ind1+1
17317 !         ind1=indmat(i,j)
17318 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
17319         do k=1,3
17320           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
17321           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
17322           enddo
17323         enddo
17324       if (i.gt.1) g(i-1)=gphii
17325       if (n.gt.nphi) g(nphi+i)=gthetai
17326       enddo
17327       if (n.le.nphi+ntheta) goto 10
17328       do i=2,nres-1
17329       if (itype(i,1).ne.10) then
17330           galphai=0.0D0
17331         gomegai=0.0D0
17332         do k=1,3
17333           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
17334           enddo
17335         do k=1,3
17336           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
17337           enddo
17338           g(ialph(i,1))=galphai
17339         g(ialph(i,1)+nside)=gomegai
17340         endif
17341       enddo
17342 !
17343 ! Add the components corresponding to local energy terms.
17344 !
17345    10 continue
17346       do i=1,nvar
17347 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
17348         g(i)=g(i)+gloc(i,icg)
17349       enddo
17350 ! Uncomment following three lines for diagnostics.
17351 !d    call intout
17352 !elwrite(iout,*) "in gradient after calling intout"
17353 !d    call briefout(0,0.0d0)
17354 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
17355       return
17356       end subroutine gradient
17357 !-----------------------------------------------------------------------------
17358       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
17359
17360       use comm_chu
17361 !      implicit real*8 (a-h,o-z)
17362 !      include 'DIMENSIONS'
17363 !      include 'COMMON.DERIV'
17364 !      include 'COMMON.IOUNITS'
17365 !      include 'COMMON.GEO'
17366       integer :: n,nf
17367 !el      integer :: jjj
17368 !el      common /chuju/ jjj
17369       real(kind=8) :: energia(0:n_ene)
17370       integer :: uiparm(1)
17371       real(kind=8) :: urparm(1)
17372       real(kind=8) :: f
17373       real(kind=8),external :: ufparm
17374       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
17375 !     if (jjj.gt.0) then
17376 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
17377 !     endif
17378       nfl=nf
17379       icg=mod(nf,2)+1
17380 !d      print *,'func',nf,nfl,icg
17381       call var_to_geom(n,x)
17382       call zerograd
17383       call chainbuild
17384 !d    write (iout,*) 'ETOTAL called from FUNC'
17385       call etotal(energia)
17386       call sum_gradient
17387       f=energia(0)
17388 !     if (jjj.gt.0) then
17389 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
17390 !       write (iout,*) 'f=',etot
17391 !       jjj=0
17392 !     endif
17393       return
17394       end subroutine func
17395 !-----------------------------------------------------------------------------
17396       subroutine cartgrad
17397 !      implicit real*8 (a-h,o-z)
17398 !      include 'DIMENSIONS'
17399       use energy_data
17400       use MD_data, only: totT,usampl,eq_time
17401 #ifdef MPI
17402       include 'mpif.h'
17403 #endif
17404 !      include 'COMMON.CHAIN'
17405 !      include 'COMMON.DERIV'
17406 !      include 'COMMON.VAR'
17407 !      include 'COMMON.INTERACT'
17408 !      include 'COMMON.FFIELD'
17409 !      include 'COMMON.MD'
17410 !      include 'COMMON.IOUNITS'
17411 !      include 'COMMON.TIME1'
17412 !
17413       integer :: i,j
17414       real(kind=8) :: time00,time01
17415
17416 ! This subrouting calculates total Cartesian coordinate gradient.
17417 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
17418 !
17419 !#define DEBUG
17420 #ifdef TIMINGtime01
17421       time00=MPI_Wtime()
17422 #endif
17423       icg=1
17424       call sum_gradient
17425 #ifdef TIMING
17426 #endif
17427 !#define DEBUG
17428 !el      write (iout,*) "After sum_gradient"
17429 !#ifdef DEBUG
17430 !      write (iout,*) "After sum_gradient"
17431 !      do i=1,nres-1
17432 !        write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
17433 !        write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
17434 !      enddo
17435 !#endif
17436 !#undef DEBUG
17437 ! If performing constraint dynamics, add the gradients of the constraint energy
17438       if(usampl.and.totT.gt.eq_time) then
17439          do i=1,nct
17440            do j=1,3
17441              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
17442              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
17443            enddo
17444          enddo
17445          do i=1,nres-3
17446            gloc(i,icg)=gloc(i,icg)+dugamma(i)
17447          enddo
17448          do i=1,nres-2
17449            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
17450          enddo
17451       endif
17452 !elwrite (iout,*) "After sum_gradient"
17453 #ifdef TIMING
17454       time01=MPI_Wtime()
17455 #endif
17456       call intcartderiv
17457 !elwrite (iout,*) "After sum_gradient"
17458 #ifdef TIMING
17459       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
17460 #endif
17461 !     call checkintcartgrad
17462 !     write(iout,*) 'calling int_to_cart'
17463 !#define DEBUG
17464 #ifdef DEBUG
17465       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
17466 #endif
17467       do i=0,nct
17468         do j=1,3
17469           gcart(j,i)=gradc(j,i,icg)
17470           gxcart(j,i)=gradx(j,i,icg)
17471 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
17472         enddo
17473 #ifdef DEBUG
17474         write (iout,'(i5,2(3f10.5,5x),4f10.5)') i,(gcart(j,i),j=1,3),&
17475           (gxcart(j,i),j=1,3),gloc(i,icg),(gloc_sc(j,i,icg),j=1,3)
17476 #endif
17477       enddo
17478 #ifdef TIMING
17479       time01=MPI_Wtime()
17480 #endif
17481 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17482       call int_to_cart
17483 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
17484
17485 #ifdef TIMING
17486             time_inttocart=time_inttocart+MPI_Wtime()-time01
17487 #endif
17488 #ifdef DEBUG
17489             write (iout,*) "gcart and gxcart after int_to_cart"
17490             do i=0,nres-1
17491             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
17492             (gxcart(j,i),j=1,3)
17493             enddo
17494 #endif
17495 !#undef DEBUG
17496 #ifdef CARGRAD
17497 #ifdef DEBUG
17498             write (iout,*) "CARGRAD"
17499 #endif
17500             do i=nres,0,-1
17501             do j=1,3
17502               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17503       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
17504             enddo
17505       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
17506       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
17507             enddo
17508       ! Correction: dummy residues
17509             if (nnt.gt.1) then
17510               do j=1,3
17511       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
17512             gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
17513             enddo
17514           endif
17515           if (nct.lt.nres) then
17516             do j=1,3
17517       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
17518             gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
17519             enddo
17520           endif
17521 #endif
17522 #ifdef TIMING
17523           time_cartgrad=time_cartgrad+MPI_Wtime()-time00
17524 #endif
17525 !#undef DEBUG
17526           return
17527           end subroutine cartgrad
17528       !-----------------------------------------------------------------------------
17529           subroutine zerograd
17530       !      implicit real*8 (a-h,o-z)
17531       !      include 'DIMENSIONS'
17532       !      include 'COMMON.DERIV'
17533       !      include 'COMMON.CHAIN'
17534       !      include 'COMMON.VAR'
17535       !      include 'COMMON.MD'
17536       !      include 'COMMON.SCCOR'
17537       !
17538       !el local variables
17539           integer :: i,j,intertyp,k
17540       ! Initialize Cartesian-coordinate gradient
17541       !
17542       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
17543       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
17544
17545       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
17546       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
17547       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
17548       !      allocate(gradcorr_long(3,nres))
17549       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
17550       !      allocate(gcorr6_turn_long(3,nres))
17551       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
17552
17553       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
17554
17555       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
17556       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
17557
17558       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
17559       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
17560
17561       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
17562       !      allocate(gscloc(3,nres)) !(3,maxres)
17563       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
17564
17565
17566
17567       !      common /deriv_scloc/
17568       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
17569       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
17570       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
17571       !      common /mpgrad/
17572       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
17573
17574
17575
17576       !          gradc(j,i,icg)=0.0d0
17577       !          gradx(j,i,icg)=0.0d0
17578
17579       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
17580       !elwrite(iout,*) "icg",icg
17581           do i=-1,nres
17582           do j=1,3
17583             gvdwx(j,i)=0.0D0
17584             gradx_scp(j,i)=0.0D0
17585             gvdwc(j,i)=0.0D0
17586             gvdwc_scp(j,i)=0.0D0
17587             gvdwc_scpp(j,i)=0.0d0
17588             gelc(j,i)=0.0D0
17589             gelc_long(j,i)=0.0D0
17590             gradb(j,i)=0.0d0
17591             gradbx(j,i)=0.0d0
17592             gvdwpp(j,i)=0.0d0
17593             gel_loc(j,i)=0.0d0
17594             gel_loc_long(j,i)=0.0d0
17595             ghpbc(j,i)=0.0D0
17596             ghpbx(j,i)=0.0D0
17597             gcorr3_turn(j,i)=0.0d0
17598             gcorr4_turn(j,i)=0.0d0
17599             gradcorr(j,i)=0.0d0
17600             gradcorr_long(j,i)=0.0d0
17601             gradcorr5_long(j,i)=0.0d0
17602             gradcorr6_long(j,i)=0.0d0
17603             gcorr6_turn_long(j,i)=0.0d0
17604             gradcorr5(j,i)=0.0d0
17605             gradcorr6(j,i)=0.0d0
17606             gcorr6_turn(j,i)=0.0d0
17607             gsccorc(j,i)=0.0d0
17608             gsccorx(j,i)=0.0d0
17609             gradc(j,i,icg)=0.0d0
17610             gradx(j,i,icg)=0.0d0
17611             gscloc(j,i)=0.0d0
17612             gsclocx(j,i)=0.0d0
17613             gliptran(j,i)=0.0d0
17614             gliptranx(j,i)=0.0d0
17615             gliptranc(j,i)=0.0d0
17616             gshieldx(j,i)=0.0d0
17617             gshieldc(j,i)=0.0d0
17618             gshieldc_loc(j,i)=0.0d0
17619             gshieldx_ec(j,i)=0.0d0
17620             gshieldc_ec(j,i)=0.0d0
17621             gshieldc_loc_ec(j,i)=0.0d0
17622             gshieldx_t3(j,i)=0.0d0
17623             gshieldc_t3(j,i)=0.0d0
17624             gshieldc_loc_t3(j,i)=0.0d0
17625             gshieldx_t4(j,i)=0.0d0
17626             gshieldc_t4(j,i)=0.0d0
17627             gshieldc_loc_t4(j,i)=0.0d0
17628             gshieldx_ll(j,i)=0.0d0
17629             gshieldc_ll(j,i)=0.0d0
17630             gshieldc_loc_ll(j,i)=0.0d0
17631             gg_tube(j,i)=0.0d0
17632             gg_tube_sc(j,i)=0.0d0
17633             gradafm(j,i)=0.0d0
17634             gradb_nucl(j,i)=0.0d0
17635             gradbx_nucl(j,i)=0.0d0
17636             gvdwpp_nucl(j,i)=0.0d0
17637             gvdwpp(j,i)=0.0d0
17638             gelpp(j,i)=0.0d0
17639             gvdwpsb(j,i)=0.0d0
17640             gvdwpsb1(j,i)=0.0d0
17641             gvdwsbc(j,i)=0.0d0
17642             gvdwsbx(j,i)=0.0d0
17643             gelsbc(j,i)=0.0d0
17644             gradcorr_nucl(j,i)=0.0d0
17645             gradcorr3_nucl(j,i)=0.0d0
17646             gradxorr_nucl(j,i)=0.0d0
17647             gradxorr3_nucl(j,i)=0.0d0
17648             gelsbx(j,i)=0.0d0
17649             gsbloc(j,i)=0.0d0
17650             gsblocx(j,i)=0.0d0
17651             gradpepcat(j,i)=0.0d0
17652             gradpepcatx(j,i)=0.0d0
17653             gradcatcat(j,i)=0.0d0
17654             gvdwx_scbase(j,i)=0.0d0
17655             gvdwc_scbase(j,i)=0.0d0
17656             gvdwx_pepbase(j,i)=0.0d0
17657             gvdwc_pepbase(j,i)=0.0d0
17658             gvdwx_scpho(j,i)=0.0d0
17659             gvdwc_scpho(j,i)=0.0d0
17660             gvdwc_peppho(j,i)=0.0d0
17661             gradnuclcatx(j,i)=0.0d0
17662             gradnuclcat(j,i)=0.0d0
17663             duscdiff(j,i)=0.0d0
17664             duscdiffx(j,i)=0.0d0
17665           enddo
17666            enddo
17667           do i=0,nres
17668           do j=1,3
17669             do intertyp=1,3
17670              gloc_sc(intertyp,i,icg)=0.0d0
17671             enddo
17672           enddo
17673           enddo
17674           do i=1,nres
17675            do j=1,maxcontsshi
17676            shield_list(j,i)=0
17677           do k=1,3
17678       !C           print *,i,j,k
17679              grad_shield_side(k,j,i)=0.0d0
17680              grad_shield_loc(k,j,i)=0.0d0
17681            enddo
17682            enddo
17683            ishield_list(i)=0
17684           enddo
17685
17686       !
17687       ! Initialize the gradient of local energy terms.
17688       !
17689       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
17690       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
17691       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
17692       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
17693       !      allocate(gel_loc_turn3(nres))
17694       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
17695       !      allocate(gsccor_loc(nres))      !(maxres)
17696
17697           do i=1,4*nres
17698           gloc(i,icg)=0.0D0
17699           enddo
17700           do i=1,nres
17701           gel_loc_loc(i)=0.0d0
17702           gcorr_loc(i)=0.0d0
17703           g_corr5_loc(i)=0.0d0
17704           g_corr6_loc(i)=0.0d0
17705           gel_loc_turn3(i)=0.0d0
17706           gel_loc_turn4(i)=0.0d0
17707           gel_loc_turn6(i)=0.0d0
17708           gsccor_loc(i)=0.0d0
17709           enddo
17710       ! initialize gcart and gxcart
17711       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
17712           do i=0,nres
17713           do j=1,3
17714             gcart(j,i)=0.0d0
17715             gxcart(j,i)=0.0d0
17716           enddo
17717           enddo
17718           return
17719           end subroutine zerograd
17720       !-----------------------------------------------------------------------------
17721           real(kind=8) function fdum()
17722           fdum=0.0D0
17723           return
17724           end function fdum
17725       !-----------------------------------------------------------------------------
17726       ! intcartderiv.F
17727       !-----------------------------------------------------------------------------
17728           subroutine intcartderiv
17729       !      implicit real*8 (a-h,o-z)
17730       !      include 'DIMENSIONS'
17731 #ifdef MPI
17732           include 'mpif.h'
17733 #endif
17734       !      include 'COMMON.SETUP'
17735       !      include 'COMMON.CHAIN'
17736       !      include 'COMMON.VAR'
17737       !      include 'COMMON.GEO'
17738       !      include 'COMMON.INTERACT'
17739       !      include 'COMMON.DERIV'
17740       !      include 'COMMON.IOUNITS'
17741       !      include 'COMMON.LOCAL'
17742       !      include 'COMMON.SCCOR'
17743           real(kind=8) :: pi4,pi34
17744           real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
17745           real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
17746                   dcosomega,dsinomega !(3,3,maxres)
17747           real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
17748
17749           integer :: i,j,k
17750           real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
17751                 fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
17752                 fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
17753                 fac17,coso_inv,fac10,fac11,fac12,fac13,fac14,IERROR
17754           integer :: nres2
17755           nres2=2*nres
17756
17757       !el from module energy-------------
17758       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
17759       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
17760       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
17761
17762       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
17763       !el      allocate(dsintau(3,3,3,0:nres2))
17764       !el      allocate(dtauangle(3,3,3,0:nres2))
17765       !el      allocate(domicron(3,2,2,0:nres2))
17766       !el      allocate(dcosomicron(3,2,2,0:nres2))
17767
17768
17769
17770 #if defined(MPI) && defined(PARINTDER)
17771           if (nfgtasks.gt.1 .and. me.eq.king) &
17772           call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
17773 #endif
17774           pi4 = 0.5d0*pipol
17775           pi34 = 3*pi4
17776
17777       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
17778       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
17779
17780       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
17781           do i=1,nres
17782           do j=1,3
17783             dtheta(j,1,i)=0.0d0
17784             dtheta(j,2,i)=0.0d0
17785             dphi(j,1,i)=0.0d0
17786             dphi(j,2,i)=0.0d0
17787             dphi(j,3,i)=0.0d0
17788             dcosomicron(j,1,1,i)=0.0d0
17789             dcosomicron(j,1,2,i)=0.0d0
17790             dcosomicron(j,2,1,i)=0.0d0
17791             dcosomicron(j,2,2,i)=0.0d0
17792           enddo
17793           enddo
17794       ! Derivatives of theta's
17795 #if defined(MPI) && defined(PARINTDER)
17796       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17797           do i=max0(ithet_start-1,3),ithet_end
17798 #else
17799           do i=3,nres
17800 #endif
17801           cost=dcos(theta(i))
17802           sint=sqrt(1-cost*cost)
17803           do j=1,3
17804             dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
17805             vbld(i-1)
17806             if (((itype(i-1,1).ne.ntyp1).and.(sint.ne.0.0d0))) &
17807              dtheta(j,1,i)=-dcostheta(j,1,i)/sint
17808             dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
17809             vbld(i)
17810             if ((itype(i-1,1).ne.ntyp1).and.(sint.ne.0.0d0))&
17811              dtheta(j,2,i)=-dcostheta(j,2,i)/sint
17812           enddo
17813           enddo
17814 #if defined(MPI) && defined(PARINTDER)
17815       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
17816           do i=max0(ithet_start-1,3),ithet_end
17817 #else
17818           do i=3,nres
17819 #endif
17820           if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1).and.molnum(i).ne.5) then
17821           cost1=dcos(omicron(1,i))
17822           sint1=sqrt(1-cost1*cost1)
17823           cost2=dcos(omicron(2,i))
17824           sint2=sqrt(1-cost2*cost2)
17825            do j=1,3
17826       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
17827             dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
17828             cost1*dc_norm(j,i-2))/ &
17829             vbld(i-1)
17830             domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
17831             dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
17832             +cost1*(dc_norm(j,i-1+nres)))/ &
17833             vbld(i-1+nres)
17834             domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
17835       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
17836       !C Looks messy but better than if in loop
17837             dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
17838             +cost2*dc_norm(j,i-1))/ &
17839             vbld(i)
17840             domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
17841             dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
17842              +cost2*(-dc_norm(j,i-1+nres)))/ &
17843             vbld(i-1+nres)
17844       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
17845             domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
17846           enddo
17847            endif
17848           enddo
17849       !elwrite(iout,*) "after vbld write"
17850       ! Derivatives of phi:
17851       ! If phi is 0 or 180 degrees, then the formulas
17852       ! have to be derived by power series expansion of the
17853       ! conventional formulas around 0 and 180.
17854 #ifdef PARINTDER
17855           do i=iphi1_start,iphi1_end
17856 #else
17857           do i=4,nres
17858 #endif
17859       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
17860       ! the conventional case
17861           sint=dsin(theta(i))
17862           sint1=dsin(theta(i-1))
17863           sing=dsin(phi(i))
17864           cost=dcos(theta(i))
17865           cost1=dcos(theta(i-1))
17866           cosg=dcos(phi(i))
17867           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
17868           if ((sint*sint1).eq.0.0d0) then
17869           fac0=0.0d0
17870           else
17871           fac0=1.0d0/(sint1*sint)
17872           endif
17873           fac1=cost*fac0
17874           fac2=cost1*fac0
17875           if (sint1.ne.0.0d0) then
17876           fac3=cosg*cost1/(sint1*sint1)
17877           else
17878           fac3=0.0d0
17879           endif
17880           if (sint.ne.0.0d0) then
17881           fac4=cosg*cost/(sint*sint)
17882           else
17883           fac4=0.0d0
17884           endif
17885       !    Obtaining the gamma derivatives from sine derivative
17886            if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
17887              phi(i).gt.pi34.and.phi(i).le.pi.or. &
17888              phi(i).ge.-pi.and.phi(i).le.-pi34) then
17889            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17890            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
17891            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17892            do j=1,3
17893             if (sint.ne.0.0d0) then
17894             ctgt=cost/sint
17895             else
17896             ctgt=0.0d0
17897             endif
17898             if (sint1.ne.0.0d0) then
17899             ctgt1=cost1/sint1
17900             else
17901             ctgt1=0.0d0
17902             endif
17903             cosg_inv=1.0d0/cosg
17904             if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17905             dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17906               -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
17907             dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
17908             dsinphi(j,2,i)= &
17909               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
17910               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17911             dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
17912             dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
17913               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
17914       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17915             dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
17916             endif
17917 !             write(iout,*) "just after,close to pi",dphi(j,3,i),&
17918 !              sing*(ctgt1*dtheta(j,2,i-1)),ctgt*dtheta(j,1,i), &
17919 !              (fac0*vp2(j)+sing*dc_norm(j,i-2)),vbld_inv(i-1)
17920
17921       ! Bug fixed 3/24/05 (AL)
17922            enddo
17923       !   Obtaining the gamma derivatives from cosine derivative
17924           else
17925              do j=1,3
17926              if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
17927              dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17928              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
17929              dc_norm(j,i-3))/vbld(i-2)
17930              dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
17931              dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17932              dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17933              dcostheta(j,1,i)
17934              dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
17935              dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
17936              dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17937              dc_norm(j,i-1))/vbld(i)
17938              dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
17939 !#define DEBUG
17940 #ifdef DEBUG
17941              write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
17942 #endif
17943 !#undef DEBUG
17944              endif
17945            enddo
17946           endif
17947           enddo
17948       !alculate derivative of Tauangle
17949 #ifdef PARINTDER
17950           do i=itau_start,itau_end
17951 #else
17952           do i=3,nres
17953       !elwrite(iout,*) " vecpr",i,nres
17954 #endif
17955            if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17956       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
17957       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
17958       !c dtauangle(j,intertyp,dervityp,residue number)
17959       !c INTERTYP=1 SC...Ca...Ca..Ca
17960       ! the conventional case
17961           sint=dsin(theta(i))
17962           sint1=dsin(omicron(2,i-1))
17963           sing=dsin(tauangle(1,i))
17964           cost=dcos(theta(i))
17965           cost1=dcos(omicron(2,i-1))
17966           cosg=dcos(tauangle(1,i))
17967       !elwrite(iout,*) " vecpr5",i,nres
17968           do j=1,3
17969       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
17970       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
17971           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17972       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
17973           enddo
17974           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
17975       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac
17976         if ((sint*sint1).eq.0.0d0) then
17977           fac0=0.0d0
17978           else
17979           fac0=1.0d0/(sint1*sint)
17980           endif
17981           fac1=cost*fac0
17982           fac2=cost1*fac0
17983           if (sint1.ne.0.0d0) then
17984           fac3=cosg*cost1/(sint1*sint1)
17985           else
17986           fac3=0.0d0
17987           endif
17988           if (sint.ne.0.0d0) then
17989           fac4=cosg*cost/(sint*sint)
17990           else
17991           fac4=0.0d0
17992           endif
17993
17994       !    Obtaining the gamma derivatives from sine derivative
17995            if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
17996              tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
17997              tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
17998            call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
17999            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
18000            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
18001           do j=1,3
18002             ctgt=cost/sint
18003             ctgt1=cost1/sint1
18004             cosg_inv=1.0d0/cosg
18005             dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
18006            -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
18007            *vbld_inv(i-2+nres)
18008             dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
18009             dsintau(j,1,2,i)= &
18010               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
18011               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18012       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
18013             dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
18014       ! Bug fixed 3/24/05 (AL)
18015             dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
18016               +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
18017       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
18018             dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
18019            enddo
18020       !   Obtaining the gamma derivatives from cosine derivative
18021           else
18022              do j=1,3
18023              dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
18024              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
18025              (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
18026              dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
18027              dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
18028              dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
18029              dcostheta(j,1,i)
18030              dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
18031              dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
18032              dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
18033              dc_norm(j,i-1))/vbld(i)
18034              dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
18035       !         write (iout,*) "else",i
18036            enddo
18037           endif
18038       !        do k=1,3
18039       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
18040       !        enddo
18041           enddo
18042       !C Second case Ca...Ca...Ca...SC
18043 #ifdef PARINTDER
18044           do i=itau_start,itau_end
18045 #else
18046           do i=4,nres
18047 #endif
18048            if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
18049             (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
18050       ! the conventional case
18051           sint=dsin(omicron(1,i))
18052           sint1=dsin(theta(i-1))
18053           sing=dsin(tauangle(2,i))
18054           cost=dcos(omicron(1,i))
18055           cost1=dcos(theta(i-1))
18056           cosg=dcos(tauangle(2,i))
18057       !        do j=1,3
18058       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
18059       !        enddo
18060           scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
18061         if ((sint*sint1).eq.0.0d0) then
18062           fac0=0.0d0
18063           else
18064           fac0=1.0d0/(sint1*sint)
18065           endif
18066           fac1=cost*fac0
18067           fac2=cost1*fac0
18068           if (sint1.ne.0.0d0) then
18069           fac3=cosg*cost1/(sint1*sint1)
18070           else
18071           fac3=0.0d0
18072           endif
18073           if (sint.ne.0.0d0) then
18074           fac4=cosg*cost/(sint*sint)
18075           else
18076           fac4=0.0d0
18077           endif
18078       !    Obtaining the gamma derivatives from sine derivative
18079            if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
18080              tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
18081              tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
18082            call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
18083            call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
18084            call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
18085           do j=1,3
18086             ctgt=cost/sint
18087             ctgt1=cost1/sint1
18088             cosg_inv=1.0d0/cosg
18089             dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
18090               +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
18091       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
18092       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
18093             dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
18094             dsintau(j,2,2,i)= &
18095               -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
18096               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18097       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
18098       !     & sing*ctgt*domicron(j,1,2,i),
18099       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18100             dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
18101       ! Bug fixed 3/24/05 (AL)
18102             dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
18103              +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
18104       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
18105             dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
18106            enddo
18107       !   Obtaining the gamma derivatives from cosine derivative
18108           else
18109              do j=1,3
18110              dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
18111              dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
18112              dc_norm(j,i-3))/vbld(i-2)
18113              dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
18114              dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
18115              dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
18116              dcosomicron(j,1,1,i)
18117              dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
18118              dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
18119              dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
18120              dc_norm(j,i-1+nres))/vbld(i-1+nres)
18121              dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
18122       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
18123            enddo
18124           endif
18125           enddo
18126
18127       !CC third case SC...Ca...Ca...SC
18128 #ifdef PARINTDER
18129
18130           do i=itau_start,itau_end
18131 #else
18132           do i=3,nres
18133 #endif
18134       ! the conventional case
18135           if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
18136           (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
18137           sint=dsin(omicron(1,i))
18138           sint1=dsin(omicron(2,i-1))
18139           sing=dsin(tauangle(3,i))
18140           cost=dcos(omicron(1,i))
18141           cost1=dcos(omicron(2,i-1))
18142           cosg=dcos(tauangle(3,i))
18143           do j=1,3
18144           dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
18145       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
18146           enddo
18147           scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
18148         if ((sint*sint1).eq.0.0d0) then
18149           fac0=0.0d0
18150           else
18151           fac0=1.0d0/(sint1*sint)
18152           endif
18153           fac1=cost*fac0
18154           fac2=cost1*fac0
18155           if (sint1.ne.0.0d0) then
18156           fac3=cosg*cost1/(sint1*sint1)
18157           else
18158           fac3=0.0d0
18159           endif
18160           if (sint.ne.0.0d0) then
18161           fac4=cosg*cost/(sint*sint)
18162           else
18163           fac4=0.0d0
18164           endif
18165       !    Obtaining the gamma derivatives from sine derivative
18166            if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
18167              tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
18168              tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
18169            call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
18170            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
18171            call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
18172           do j=1,3
18173             ctgt=cost/sint
18174             ctgt1=cost1/sint1
18175             cosg_inv=1.0d0/cosg
18176             dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
18177               -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
18178               *vbld_inv(i-2+nres)
18179             dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
18180             dsintau(j,3,2,i)= &
18181               -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
18182               -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
18183             dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
18184       ! Bug fixed 3/24/05 (AL)
18185             dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
18186               +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
18187               *vbld_inv(i-1+nres)
18188       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
18189             dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
18190            enddo
18191       !   Obtaining the gamma derivatives from cosine derivative
18192           else
18193              do j=1,3
18194              dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
18195              dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
18196              dc_norm2(j,i-2+nres))/vbld(i-2+nres)
18197              dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
18198              dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
18199              dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
18200              dcosomicron(j,1,1,i)
18201              dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
18202              dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
18203              dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
18204              dc_norm(j,i-1+nres))/vbld(i-1+nres)
18205              dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
18206       !          write(iout,*) "else",i
18207            enddo
18208           endif
18209           enddo
18210
18211 #ifdef CRYST_SC
18212       !   Derivatives of side-chain angles alpha and omega
18213 #if defined(MPI) && defined(PARINTDER)
18214           do i=ibond_start,ibond_end
18215 #else
18216           do i=2,nres-1
18217 #endif
18218             if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
18219              fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
18220              fac6=fac5/vbld(i)
18221              fac7=fac5*fac5
18222              fac8=fac5/vbld(i+1)
18223              fac9=fac5/vbld(i+nres)
18224              scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
18225              scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
18226              cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
18227              (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
18228              -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
18229              sina=sqrt(1-cosa*cosa)
18230              sino=dsin(omeg(i))
18231       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
18232              do j=1,3
18233               dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
18234               dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
18235               dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
18236               dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
18237               scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
18238               dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
18239               dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
18240               dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
18241               vbld(i+nres))
18242               dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
18243             enddo
18244       ! obtaining the derivatives of omega from sines
18245             if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
18246                omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
18247                omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
18248                fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
18249                dsin(theta(i+1)))
18250                fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
18251                fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
18252                call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
18253                call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
18254                call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
18255                coso_inv=1.0d0/dcos(omeg(i))
18256                do j=1,3
18257                dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
18258                +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
18259                (sino*dc_norm(j,i-1))/vbld(i)
18260                domega(j,1,i)=coso_inv*dsinomega(j,1,i)
18261                dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
18262                +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
18263                -sino*dc_norm(j,i)/vbld(i+1)
18264                domega(j,2,i)=coso_inv*dsinomega(j,2,i)
18265                dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
18266                fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
18267                vbld(i+nres)
18268                domega(j,3,i)=coso_inv*dsinomega(j,3,i)
18269               enddo
18270              else
18271       !   obtaining the derivatives of omega from cosines
18272              fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
18273              fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
18274              fac12=fac10*sina
18275              fac13=fac12*fac12
18276              fac14=sina*sina
18277              do j=1,3
18278               dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
18279               dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
18280               (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
18281               fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
18282               domega(j,1,i)=-1/sino*dcosomega(j,1,i)
18283               dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
18284               dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
18285               dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
18286               (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
18287               dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
18288               domega(j,2,i)=-1/sino*dcosomega(j,2,i)
18289               dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
18290               scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
18291               (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
18292               domega(j,3,i)=-1/sino*dcosomega(j,3,i)
18293             enddo
18294             endif
18295            else
18296              do j=1,3
18297              do k=1,3
18298                dalpha(k,j,i)=0.0d0
18299                domega(k,j,i)=0.0d0
18300              enddo
18301              enddo
18302            endif
18303            enddo
18304 #endif
18305 #if defined(MPI) && defined(PARINTDER)
18306           if (nfgtasks.gt.1) then
18307 #ifdef DEBUG
18308       !d      write (iout,*) "Gather dtheta"
18309       !d      call flush(iout)
18310           write (iout,*) "dtheta before gather"
18311           do i=1,nres
18312           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
18313           enddo
18314 #endif
18315           call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
18316           MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
18317           king,FG_COMM,IERROR)
18318 !#define DEBUG
18319 #ifdef DEBUG
18320       !d      write (iout,*) "Gather dphi"
18321       !d      call flush(iout)
18322           write (iout,*) "dphi before gather"
18323           do i=1,nres
18324           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
18325           enddo
18326 #endif
18327 !#undef DEBUG
18328           call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
18329           MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
18330           king,FG_COMM,IERROR)
18331       !d      write (iout,*) "Gather dalpha"
18332       !d      call flush(iout)
18333 #ifdef CRYST_SC
18334           call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
18335           MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
18336           king,FG_COMM,IERROR)
18337       !d      write (iout,*) "Gather domega"
18338       !d      call flush(iout)
18339           call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
18340           MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
18341           king,FG_COMM,IERROR)
18342 #endif
18343           endif
18344 #endif
18345 !#define DEBUG
18346 #ifdef DEBUG
18347           write (iout,*) "dtheta after gather"
18348           do i=1,nres
18349           write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
18350           enddo
18351           write (iout,*) "dphi after gather"
18352           do i=1,nres
18353           write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
18354           enddo
18355           write (iout,*) "dalpha after gather"
18356           do i=1,nres
18357           write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
18358           enddo
18359           write (iout,*) "domega after gather"
18360           do i=1,nres
18361           write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
18362           enddo
18363 #endif
18364 !#undef DEBUG
18365           return
18366           end subroutine intcartderiv
18367       !-----------------------------------------------------------------------------
18368           subroutine checkintcartgrad
18369       !      implicit real*8 (a-h,o-z)
18370       !      include 'DIMENSIONS'
18371 #ifdef MPI
18372           include 'mpif.h'
18373 #endif
18374       !      include 'COMMON.CHAIN'
18375       !      include 'COMMON.VAR'
18376       !      include 'COMMON.GEO'
18377       !      include 'COMMON.INTERACT'
18378       !      include 'COMMON.DERIV'
18379       !      include 'COMMON.IOUNITS'
18380       !      include 'COMMON.SETUP'
18381           real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
18382           real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
18383           real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
18384           real(kind=8),dimension(3) :: dc_norm_s
18385           real(kind=8) :: aincr=1.0d-5
18386           integer :: i,j
18387           real(kind=8) :: dcji
18388           do i=1,nres
18389           phi_s(i)=phi(i)
18390           theta_s(i)=theta(i)
18391           alph_s(i)=alph(i)
18392           omeg_s(i)=omeg(i)
18393           enddo
18394       ! Check theta gradient
18395           write (iout,*) &
18396            "Analytical (upper) and numerical (lower) gradient of theta"
18397           write (iout,*)
18398           do i=3,nres
18399           do j=1,3
18400             dcji=dc(j,i-2)
18401             dc(j,i-2)=dcji+aincr
18402             call chainbuild_cart
18403             call int_from_cart1(.false.)
18404         dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
18405         dc(j,i-2)=dcji
18406         dcji=dc(j,i-1)
18407         dc(j,i-1)=dc(j,i-1)+aincr
18408         call chainbuild_cart
18409         dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
18410         dc(j,i-1)=dcji
18411       enddo
18412 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
18413 !el          (dtheta(j,2,i),j=1,3)
18414 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
18415 !el          (dthetanum(j,2,i),j=1,3)
18416 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
18417 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
18418 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
18419 !el        write (iout,*)
18420       enddo
18421 ! Check gamma gradient
18422       write (iout,*) &
18423        "Analytical (upper) and numerical (lower) gradient of gamma"
18424       do i=4,nres
18425       do j=1,3
18426         dcji=dc(j,i-3)
18427         dc(j,i-3)=dcji+aincr
18428         call chainbuild_cart
18429         dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
18430             dc(j,i-3)=dcji
18431         dcji=dc(j,i-2)
18432         dc(j,i-2)=dcji+aincr
18433         call chainbuild_cart
18434         dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
18435         dc(j,i-2)=dcji
18436         dcji=dc(j,i-1)
18437         dc(j,i-1)=dc(j,i-1)+aincr
18438         call chainbuild_cart
18439         dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
18440         dc(j,i-1)=dcji
18441       enddo
18442 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
18443 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
18444 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
18445 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
18446 !el        write (iout,'(5x,3(3f10.5,5x))') &
18447 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
18448 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
18449 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
18450 !el        write (iout,*)
18451       enddo
18452 ! Check alpha gradient
18453       write (iout,*) &
18454        "Analytical (upper) and numerical (lower) gradient of alpha"
18455       do i=2,nres-1
18456        if(itype(i,1).ne.10) then
18457              do j=1,3
18458               dcji=dc(j,i-1)
18459                dc(j,i-1)=dcji+aincr
18460             call chainbuild_cart
18461             dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
18462              /aincr
18463               dc(j,i-1)=dcji
18464             dcji=dc(j,i)
18465             dc(j,i)=dcji+aincr
18466             call chainbuild_cart
18467             dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
18468              /aincr
18469             dc(j,i)=dcji
18470             dcji=dc(j,i+nres)
18471             dc(j,i+nres)=dc(j,i+nres)+aincr
18472             call chainbuild_cart
18473             dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
18474              /aincr
18475            dc(j,i+nres)=dcji
18476           enddo
18477         endif
18478 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
18479 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
18480 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
18481 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
18482 !el        write (iout,'(5x,3(3f10.5,5x))') &
18483 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
18484 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
18485 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
18486 !el        write (iout,*)
18487       enddo
18488 !     Check omega gradient
18489       write (iout,*) &
18490        "Analytical (upper) and numerical (lower) gradient of omega"
18491       do i=2,nres-1
18492        if(itype(i,1).ne.10) then
18493              do j=1,3
18494               dcji=dc(j,i-1)
18495                dc(j,i-1)=dcji+aincr
18496             call chainbuild_cart
18497             domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
18498              /aincr
18499               dc(j,i-1)=dcji
18500             dcji=dc(j,i)
18501             dc(j,i)=dcji+aincr
18502             call chainbuild_cart
18503             domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
18504              /aincr
18505             dc(j,i)=dcji
18506             dcji=dc(j,i+nres)
18507             dc(j,i+nres)=dc(j,i+nres)+aincr
18508             call chainbuild_cart
18509             domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
18510              /aincr
18511            dc(j,i+nres)=dcji
18512           enddo
18513         endif
18514 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
18515 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
18516 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
18517 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
18518 !el        write (iout,'(5x,3(3f10.5,5x))') &
18519 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
18520 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
18521 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
18522 !el        write (iout,*)
18523       enddo
18524       return
18525       end subroutine checkintcartgrad
18526 !-----------------------------------------------------------------------------
18527 ! q_measure.F
18528 !-----------------------------------------------------------------------------
18529       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
18530 !      implicit real*8 (a-h,o-z)
18531 !      include 'DIMENSIONS'
18532 !      include 'COMMON.IOUNITS'
18533 !      include 'COMMON.CHAIN'
18534 !      include 'COMMON.INTERACT'
18535 !      include 'COMMON.VAR'
18536       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
18537       integer :: kkk,nsep=3
18538       real(kind=8) :: qm      !dist,
18539       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
18540       logical :: lprn=.false.
18541       logical :: flag
18542 !      real(kind=8) :: sigm,x
18543
18544 !el      sigm(x)=0.25d0*x     ! local function
18545       qqmax=1.0d10
18546       do kkk=1,nperm
18547       qq = 0.0d0
18548       nl=0
18549        if(flag) then
18550       do il=seg1+nsep,seg2
18551         do jl=seg1,il-nsep
18552           nl=nl+1
18553           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
18554                    (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
18555                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18556           dij=dist(il,jl)
18557           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18558           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18559             nl=nl+1
18560             d0ijCM=dsqrt( &
18561                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18562                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18563                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18564             dijCM=dist(il+nres,jl+nres)
18565             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18566           endif
18567           qq = qq+qqij+qqijCM
18568         enddo
18569       enddo
18570       qq = qq/nl
18571       else
18572       do il=seg1,seg2
18573       if((seg3-il).lt.3) then
18574            secseg=il+3
18575       else
18576            secseg=seg3
18577       endif
18578         do jl=secseg,seg4
18579           nl=nl+1
18580           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18581                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18582                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18583           dij=dist(il,jl)
18584           qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
18585           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18586             nl=nl+1
18587             d0ijCM=dsqrt( &
18588                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18589                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18590                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18591             dijCM=dist(il+nres,jl+nres)
18592             qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
18593           endif
18594           qq = qq+qqij+qqijCM
18595         enddo
18596       enddo
18597       qq = qq/nl
18598       endif
18599       if (qqmax.le.qq) qqmax=qq
18600       enddo
18601       qwolynes=1.0d0-qqmax
18602       return
18603       end function qwolynes
18604 !-----------------------------------------------------------------------------
18605       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
18606 !      implicit real*8 (a-h,o-z)
18607 !      include 'DIMENSIONS'
18608 !      include 'COMMON.IOUNITS'
18609 !      include 'COMMON.CHAIN'
18610 !      include 'COMMON.INTERACT'
18611 !      include 'COMMON.VAR'
18612 !      include 'COMMON.MD'
18613       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
18614       integer :: nsep=3, kkk
18615 !el      real(kind=8) :: dist
18616       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
18617       logical :: lprn=.false.
18618       logical :: flag
18619       real(kind=8) :: sim,dd0,fac,ddqij
18620 !el      sigm(x)=0.25d0*x           ! local function
18621       do kkk=1,nperm
18622       do i=0,nres
18623       do j=1,3
18624         dqwol(j,i)=0.0d0
18625         dxqwol(j,i)=0.0d0
18626       enddo
18627       enddo
18628       nl=0
18629        if(flag) then
18630       do il=seg1+nsep,seg2
18631         do jl=seg1,il-nsep
18632           nl=nl+1
18633           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18634                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18635                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18636           dij=dist(il,jl)
18637           sim = 1.0d0/sigm(d0ij)
18638           sim = sim*sim
18639           dd0 = dij-d0ij
18640           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18641         do k=1,3
18642             ddqij = (c(k,il)-c(k,jl))*fac
18643             dqwol(k,il)=dqwol(k,il)+ddqij
18644             dqwol(k,jl)=dqwol(k,jl)-ddqij
18645           enddo
18646
18647           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18648             nl=nl+1
18649             d0ijCM=dsqrt( &
18650                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18651                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18652                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18653             dijCM=dist(il+nres,jl+nres)
18654             sim = 1.0d0/sigm(d0ijCM)
18655             sim = sim*sim
18656             dd0=dijCM-d0ijCM
18657             fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18658             do k=1,3
18659             ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18660             dxqwol(k,il)=dxqwol(k,il)+ddqij
18661             dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18662             enddo
18663           endif
18664         enddo
18665       enddo
18666        else
18667       do il=seg1,seg2
18668       if((seg3-il).lt.3) then
18669            secseg=il+3
18670       else
18671            secseg=seg3
18672       endif
18673         do jl=secseg,seg4
18674           nl=nl+1
18675           d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
18676                    (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
18677                    (cref(3,jl,kkk)-cref(3,il,kkk))**2)
18678           dij=dist(il,jl)
18679           sim = 1.0d0/sigm(d0ij)
18680           sim = sim*sim
18681           dd0 = dij-d0ij
18682           fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
18683           do k=1,3
18684             ddqij = (c(k,il)-c(k,jl))*fac
18685             dqwol(k,il)=dqwol(k,il)+ddqij
18686             dqwol(k,jl)=dqwol(k,jl)-ddqij
18687           enddo
18688           if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
18689             nl=nl+1
18690             d0ijCM=dsqrt( &
18691                  (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
18692                  (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
18693                  (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
18694             dijCM=dist(il+nres,jl+nres)
18695             sim = 1.0d0/sigm(d0ijCM)
18696             sim=sim*sim
18697             dd0 = dijCM-d0ijCM
18698             fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
18699             do k=1,3
18700              ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
18701              dxqwol(k,il)=dxqwol(k,il)+ddqij
18702              dxqwol(k,jl)=dxqwol(k,jl)-ddqij
18703             enddo
18704           endif
18705         enddo
18706       enddo
18707       endif
18708       enddo
18709        do i=0,nres
18710        do j=1,3
18711          dqwol(j,i)=dqwol(j,i)/nl
18712          dxqwol(j,i)=dxqwol(j,i)/nl
18713        enddo
18714        enddo
18715       return
18716       end subroutine qwolynes_prim
18717 !-----------------------------------------------------------------------------
18718       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
18719 !      implicit real*8 (a-h,o-z)
18720 !      include 'DIMENSIONS'
18721 !      include 'COMMON.IOUNITS'
18722 !      include 'COMMON.CHAIN'
18723 !      include 'COMMON.INTERACT'
18724 !      include 'COMMON.VAR'
18725       integer :: seg1,seg2,seg3,seg4
18726       logical :: flag
18727       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
18728       real(kind=8),dimension(3,0:2*nres) :: cdummy
18729       real(kind=8) :: q1,q2
18730       real(kind=8) :: delta=1.0d-10
18731       integer :: i,j
18732
18733       do i=0,nres
18734       do j=1,3
18735         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18736         cdummy(j,i)=c(j,i)
18737         c(j,i)=c(j,i)+delta
18738         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18739         qwolan(j,i)=(q2-q1)/delta
18740         c(j,i)=cdummy(j,i)
18741       enddo
18742       enddo
18743       do i=0,nres
18744       do j=1,3
18745         q1=qwolynes(seg1,seg2,flag,seg3,seg4)
18746         cdummy(j,i+nres)=c(j,i+nres)
18747         c(j,i+nres)=c(j,i+nres)+delta
18748         q2=qwolynes(seg1,seg2,flag,seg3,seg4)
18749         qwolxan(j,i)=(q2-q1)/delta
18750         c(j,i+nres)=cdummy(j,i+nres)
18751       enddo
18752       enddo
18753 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
18754 !      do i=0,nct
18755 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
18756 !      enddo
18757 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
18758 !      do i=0,nct
18759 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
18760 !      enddo
18761       return
18762       end subroutine qwol_num
18763 !-----------------------------------------------------------------------------
18764       subroutine EconstrQ
18765 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
18766 !      implicit real*8 (a-h,o-z)
18767 !      include 'DIMENSIONS'
18768 !      include 'COMMON.CONTROL'
18769 !      include 'COMMON.VAR'
18770 !      include 'COMMON.MD'
18771       use MD_data
18772 !#ifndef LANG0
18773 !      include 'COMMON.LANGEVIN'
18774 !#else
18775 !      include 'COMMON.LANGEVIN.lang0'
18776 !#endif
18777 !      include 'COMMON.CHAIN'
18778 !      include 'COMMON.DERIV'
18779 !      include 'COMMON.GEO'
18780 !      include 'COMMON.LOCAL'
18781 !      include 'COMMON.INTERACT'
18782 !      include 'COMMON.IOUNITS'
18783 !      include 'COMMON.NAMES'
18784 !      include 'COMMON.TIME1'
18785       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
18786       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
18787                duconst,duxconst
18788       integer :: kstart,kend,lstart,lend,idummy
18789       real(kind=8) :: delta=1.0d-7
18790       integer :: i,j,k,ii
18791       do i=0,nres
18792        do j=1,3
18793           duconst(j,i)=0.0d0
18794           dudconst(j,i)=0.0d0
18795           duxconst(j,i)=0.0d0
18796           dudxconst(j,i)=0.0d0
18797        enddo
18798       enddo
18799       Uconst=0.0d0
18800       do i=1,nfrag
18801        qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18802          idummy,idummy)
18803        Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
18804 ! Calculating the derivatives of Constraint energy with respect to Q
18805        Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
18806          qinfrag(i,iset))
18807 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
18808 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
18809 !         hmnum=(hm2-hm1)/delta
18810 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
18811 !     &   qinfrag(i,iset))
18812 !         write(iout,*) "harmonicnum frag", hmnum
18813 ! Calculating the derivatives of Q with respect to cartesian coordinates
18814        call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
18815         idummy,idummy)
18816 !         write(iout,*) "dqwol "
18817 !         do ii=1,nres
18818 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18819 !         enddo
18820 !         write(iout,*) "dxqwol "
18821 !         do ii=1,nres
18822 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18823 !         enddo
18824 ! Calculating numerical gradients of dU/dQi and dQi/dxi
18825 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
18826 !     &  ,idummy,idummy)
18827 !  The gradients of Uconst in Cs
18828        do ii=0,nres
18829           do j=1,3
18830              duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
18831              dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
18832           enddo
18833        enddo
18834       enddo
18835       do i=1,npair
18836        kstart=ifrag(1,ipair(1,i,iset),iset)
18837        kend=ifrag(2,ipair(1,i,iset),iset)
18838        lstart=ifrag(1,ipair(2,i,iset),iset)
18839        lend=ifrag(2,ipair(2,i,iset),iset)
18840        qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
18841        Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
18842 !  Calculating dU/dQ
18843        Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
18844 !         hm1=harmonic(qpair(i),qinpair(i,iset))
18845 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
18846 !         hmnum=(hm2-hm1)/delta
18847 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
18848 !     &   qinpair(i,iset))
18849 !         write(iout,*) "harmonicnum pair ", hmnum
18850 ! Calculating dQ/dXi
18851        call qwolynes_prim(kstart,kend,.false.,&
18852         lstart,lend)
18853 !         write(iout,*) "dqwol "
18854 !         do ii=1,nres
18855 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
18856 !         enddo
18857 !         write(iout,*) "dxqwol "
18858 !         do ii=1,nres
18859 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
18860 !        enddo
18861 ! Calculating numerical gradients
18862 !        call qwol_num(kstart,kend,.false.
18863 !     &  ,lstart,lend)
18864 ! The gradients of Uconst in Cs
18865        do ii=0,nres
18866           do j=1,3
18867              duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
18868              dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
18869           enddo
18870        enddo
18871       enddo
18872 !      write(iout,*) "Uconst inside subroutine ", Uconst
18873 ! Transforming the gradients from Cs to dCs for the backbone
18874       do i=0,nres
18875        do j=i+1,nres
18876          do k=1,3
18877            dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
18878          enddo
18879        enddo
18880       enddo
18881 !  Transforming the gradients from Cs to dCs for the side chains
18882       do i=1,nres
18883        do j=1,3
18884          dudxconst(j,i)=duxconst(j,i)
18885        enddo
18886       enddo
18887 !      write(iout,*) "dU/ddc backbone "
18888 !       do ii=0,nres
18889 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
18890 !      enddo
18891 !      write(iout,*) "dU/ddX side chain "
18892 !      do ii=1,nres
18893 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
18894 !      enddo
18895 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
18896 !      call dEconstrQ_num
18897       return
18898       end subroutine EconstrQ
18899 !-----------------------------------------------------------------------------
18900       subroutine dEconstrQ_num
18901 ! Calculating numerical dUconst/ddc and dUconst/ddx
18902 !      implicit real*8 (a-h,o-z)
18903 !      include 'DIMENSIONS'
18904 !      include 'COMMON.CONTROL'
18905 !      include 'COMMON.VAR'
18906 !      include 'COMMON.MD'
18907       use MD_data
18908 !#ifndef LANG0
18909 !      include 'COMMON.LANGEVIN'
18910 !#else
18911 !      include 'COMMON.LANGEVIN.lang0'
18912 !#endif
18913 !      include 'COMMON.CHAIN'
18914 !      include 'COMMON.DERIV'
18915 !      include 'COMMON.GEO'
18916 !      include 'COMMON.LOCAL'
18917 !      include 'COMMON.INTERACT'
18918 !      include 'COMMON.IOUNITS'
18919 !      include 'COMMON.NAMES'
18920 !      include 'COMMON.TIME1'
18921       real(kind=8) :: uzap1,uzap2
18922       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
18923       integer :: kstart,kend,lstart,lend,idummy
18924       real(kind=8) :: delta=1.0d-7
18925 !el local variables
18926       integer :: i,ii,j
18927 !     real(kind=8) ::
18928 !     For the backbone
18929       do i=0,nres-1
18930        do j=1,3
18931           dUcartan(j,i)=0.0d0
18932           cdummy(j,i)=dc(j,i)
18933           dc(j,i)=dc(j,i)+delta
18934           call chainbuild_cart
18935         uzap2=0.0d0
18936           do ii=1,nfrag
18937            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18938             idummy,idummy)
18939              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18940             qinfrag(ii,iset))
18941           enddo
18942           do ii=1,npair
18943              kstart=ifrag(1,ipair(1,ii,iset),iset)
18944              kend=ifrag(2,ipair(1,ii,iset),iset)
18945              lstart=ifrag(1,ipair(2,ii,iset),iset)
18946              lend=ifrag(2,ipair(2,ii,iset),iset)
18947              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18948              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18949              qinpair(ii,iset))
18950           enddo
18951           dc(j,i)=cdummy(j,i)
18952           call chainbuild_cart
18953           uzap1=0.0d0
18954            do ii=1,nfrag
18955            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18956             idummy,idummy)
18957              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
18958             qinfrag(ii,iset))
18959           enddo
18960           do ii=1,npair
18961              kstart=ifrag(1,ipair(1,ii,iset),iset)
18962              kend=ifrag(2,ipair(1,ii,iset),iset)
18963              lstart=ifrag(1,ipair(2,ii,iset),iset)
18964              lend=ifrag(2,ipair(2,ii,iset),iset)
18965              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18966              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
18967             qinpair(ii,iset))
18968           enddo
18969           ducartan(j,i)=(uzap2-uzap1)/(delta)
18970        enddo
18971       enddo
18972 ! Calculating numerical gradients for dU/ddx
18973       do i=0,nres-1
18974        duxcartan(j,i)=0.0d0
18975        do j=1,3
18976           cdummy(j,i)=dc(j,i+nres)
18977           dc(j,i+nres)=dc(j,i+nres)+delta
18978           call chainbuild_cart
18979         uzap2=0.0d0
18980           do ii=1,nfrag
18981            qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
18982             idummy,idummy)
18983              uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
18984             qinfrag(ii,iset))
18985           enddo
18986           do ii=1,npair
18987              kstart=ifrag(1,ipair(1,ii,iset),iset)
18988              kend=ifrag(2,ipair(1,ii,iset),iset)
18989              lstart=ifrag(1,ipair(2,ii,iset),iset)
18990              lend=ifrag(2,ipair(2,ii,iset),iset)
18991              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
18992              uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
18993             qinpair(ii,iset))
18994           enddo
18995           dc(j,i+nres)=cdummy(j,i)
18996           call chainbuild_cart
18997           uzap1=0.0d0
18998            do ii=1,nfrag
18999              qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
19000             ifrag(2,ii,iset),.true.,idummy,idummy)
19001              uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
19002             qinfrag(ii,iset))
19003           enddo
19004           do ii=1,npair
19005              kstart=ifrag(1,ipair(1,ii,iset),iset)
19006              kend=ifrag(2,ipair(1,ii,iset),iset)
19007              lstart=ifrag(1,ipair(2,ii,iset),iset)
19008              lend=ifrag(2,ipair(2,ii,iset),iset)
19009              qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
19010              uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
19011             qinpair(ii,iset))
19012           enddo
19013           duxcartan(j,i)=(uzap2-uzap1)/(delta)
19014        enddo
19015       enddo
19016       write(iout,*) "Numerical dUconst/ddc backbone "
19017       do ii=0,nres
19018       write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
19019       enddo
19020 !      write(iout,*) "Numerical dUconst/ddx side-chain "
19021 !      do ii=1,nres
19022 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
19023 !      enddo
19024       return
19025       end subroutine dEconstrQ_num
19026 !-----------------------------------------------------------------------------
19027 ! ssMD.F
19028 !-----------------------------------------------------------------------------
19029       subroutine check_energies
19030
19031 !      use random, only: ran_number
19032
19033 !      implicit none
19034 !     Includes
19035 !      include 'DIMENSIONS'
19036 !      include 'COMMON.CHAIN'
19037 !      include 'COMMON.VAR'
19038 !      include 'COMMON.IOUNITS'
19039 !      include 'COMMON.SBRIDGE'
19040 !      include 'COMMON.LOCAL'
19041 !      include 'COMMON.GEO'
19042
19043 !     External functions
19044 !EL      double precision ran_number
19045 !EL      external ran_number
19046
19047 !     Local variables
19048       integer :: i,j,k,l,lmax,p,pmax
19049       real(kind=8) :: rmin,rmax
19050       real(kind=8) :: eij
19051
19052       real(kind=8) :: d
19053       real(kind=8) :: wi,rij,tj,pj
19054 !      return
19055
19056       i=5
19057       j=14
19058
19059       d=dsc(1)
19060       rmin=2.0D0
19061       rmax=12.0D0
19062
19063       lmax=10000
19064       pmax=1
19065
19066       do k=1,3
19067       c(k,i)=0.0D0
19068       c(k,j)=0.0D0
19069       c(k,nres+i)=0.0D0
19070       c(k,nres+j)=0.0D0
19071       enddo
19072
19073       do l=1,lmax
19074
19075 !t        wi=ran_number(0.0D0,pi)
19076 !        wi=ran_number(0.0D0,pi/6.0D0)
19077 !        wi=0.0D0
19078 !t        tj=ran_number(0.0D0,pi)
19079 !t        pj=ran_number(0.0D0,pi)
19080 !        pj=ran_number(0.0D0,pi/6.0D0)
19081 !        pj=0.0D0
19082
19083       do p=1,pmax
19084 !t           rij=ran_number(rmin,rmax)
19085
19086          c(1,j)=d*sin(pj)*cos(tj)
19087          c(2,j)=d*sin(pj)*sin(tj)
19088          c(3,j)=d*cos(pj)
19089
19090          c(3,nres+i)=-rij
19091
19092          c(1,i)=d*sin(wi)
19093          c(3,i)=-rij-d*cos(wi)
19094
19095          do k=1,3
19096             dc(k,nres+i)=c(k,nres+i)-c(k,i)
19097             dc_norm(k,nres+i)=dc(k,nres+i)/d
19098             dc(k,nres+j)=c(k,nres+j)-c(k,j)
19099             dc_norm(k,nres+j)=dc(k,nres+j)/d
19100          enddo
19101
19102          call dyn_ssbond_ene(i,j,eij)
19103       enddo
19104       enddo
19105       call exit(1)
19106       return
19107       end subroutine check_energies
19108 !-----------------------------------------------------------------------------
19109       subroutine dyn_ssbond_ene(resi,resj,eij)
19110 !      implicit none
19111 !      Includes
19112       use calc_data
19113       use comm_sschecks
19114 !      include 'DIMENSIONS'
19115 !      include 'COMMON.SBRIDGE'
19116 !      include 'COMMON.CHAIN'
19117 !      include 'COMMON.DERIV'
19118 !      include 'COMMON.LOCAL'
19119 !      include 'COMMON.INTERACT'
19120 !      include 'COMMON.VAR'
19121 !      include 'COMMON.IOUNITS'
19122 !      include 'COMMON.CALC'
19123 #ifndef CLUST
19124 #ifndef WHAM
19125        use MD_data
19126 !      include 'COMMON.MD'
19127 !      use MD, only: totT,t_bath
19128 #endif
19129 #endif
19130 !     External functions
19131 !EL      double precision h_base
19132 !EL      external h_base
19133
19134 !     Input arguments
19135       integer :: resi,resj
19136
19137 !     Output arguments
19138       real(kind=8) :: eij
19139
19140 !     Local variables
19141       logical :: havebond
19142       integer itypi,itypj
19143       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
19144       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
19145       real(kind=8),dimension(3) :: dcosom1,dcosom2
19146       real(kind=8) :: ed
19147       real(kind=8) :: pom1,pom2
19148       real(kind=8) :: ljA,ljB,ljXs
19149       real(kind=8),dimension(1:3) :: d_ljB
19150       real(kind=8) :: ssA,ssB,ssC,ssXs
19151       real(kind=8) :: ssxm,ljxm,ssm,ljm
19152       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
19153       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
19154       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
19155 !-------FIRST METHOD
19156       real(kind=8) :: xm
19157       real(kind=8),dimension(1:3) :: d_xm
19158 !-------END FIRST METHOD
19159 !-------SECOND METHOD
19160 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
19161 !-------END SECOND METHOD
19162
19163 !-------TESTING CODE
19164 !el      logical :: checkstop,transgrad
19165 !el      common /sschecks/ checkstop,transgrad
19166
19167       integer :: icheck,nicheck,jcheck,njcheck
19168       real(kind=8),dimension(-1:1) :: echeck
19169       real(kind=8) :: deps,ssx0,ljx0
19170 !-------END TESTING CODE
19171
19172       eij=0.0d0
19173       i=resi
19174       j=resj
19175
19176 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
19177 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
19178
19179       itypi=itype(i,1)
19180       dxi=dc_norm(1,nres+i)
19181       dyi=dc_norm(2,nres+i)
19182       dzi=dc_norm(3,nres+i)
19183       dsci_inv=vbld_inv(i+nres)
19184
19185       itypj=itype(j,1)
19186       xj=c(1,nres+j)-c(1,nres+i)
19187       yj=c(2,nres+j)-c(2,nres+i)
19188       zj=c(3,nres+j)-c(3,nres+i)
19189       dxj=dc_norm(1,nres+j)
19190       dyj=dc_norm(2,nres+j)
19191       dzj=dc_norm(3,nres+j)
19192       dscj_inv=vbld_inv(j+nres)
19193
19194       chi1=chi(itypi,itypj)
19195       chi2=chi(itypj,itypi)
19196       chi12=chi1*chi2
19197       chip1=chip(itypi)
19198       chip2=chip(itypj)
19199       chip12=chip1*chip2
19200       alf1=alp(itypi)
19201       alf2=alp(itypj)
19202       alf12=0.5D0*(alf1+alf2)
19203
19204       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
19205       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
19206 !     The following are set in sc_angular
19207 !      erij(1)=xj*rij
19208 !      erij(2)=yj*rij
19209 !      erij(3)=zj*rij
19210 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
19211 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
19212 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
19213       call sc_angular
19214       rij=1.0D0/rij  ! Reset this so it makes sense
19215
19216       sig0ij=sigma(itypi,itypj)
19217       sig=sig0ij*dsqrt(1.0D0/sigsq)
19218
19219       ljXs=sig-sig0ij
19220       ljA=eps1*eps2rt**2*eps3rt**2
19221       ljB=ljA*bb_aq(itypi,itypj)
19222       ljA=ljA*aa_aq(itypi,itypj)
19223       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
19224
19225       ssXs=d0cm
19226       deltat1=1.0d0-om1
19227       deltat2=1.0d0+om2
19228       deltat12=om2-om1+2.0d0
19229       cosphi=om12-om1*om2
19230       ssA=akcm
19231       ssB=akct*deltat12
19232       ssC=ss_depth &
19233          +akth*(deltat1*deltat1+deltat2*deltat2) &
19234          +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
19235       ssxm=ssXs-0.5D0*ssB/ssA
19236
19237 !-------TESTING CODE
19238 !$$$c     Some extra output
19239 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
19240 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
19241 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
19242 !$$$      if (ssx0.gt.0.0d0) then
19243 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
19244 !$$$      else
19245 !$$$        ssx0=ssxm
19246 !$$$      endif
19247 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
19248 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
19249 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
19250 !$$$      return
19251 !-------END TESTING CODE
19252
19253 !-------TESTING CODE
19254 !     Stop and plot energy and derivative as a function of distance
19255       if (checkstop) then
19256       ssm=ssC-0.25D0*ssB*ssB/ssA
19257       ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
19258       if (ssm.lt.ljm .and. &
19259            dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
19260         nicheck=1000
19261         njcheck=1
19262         deps=0.5d-7
19263       else
19264         checkstop=.false.
19265       endif
19266       endif
19267       if (.not.checkstop) then
19268       nicheck=0
19269       njcheck=-1
19270       endif
19271
19272       do icheck=0,nicheck
19273       do jcheck=-1,njcheck
19274       if (checkstop) rij=(ssxm-1.0d0)+ &
19275            ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
19276 !-------END TESTING CODE
19277
19278       if (rij.gt.ljxm) then
19279       havebond=.false.
19280       ljd=rij-ljXs
19281       fac=(1.0D0/ljd)**expon
19282       e1=fac*fac*aa_aq(itypi,itypj)
19283       e2=fac*bb_aq(itypi,itypj)
19284       eij=eps1*eps2rt*eps3rt*(e1+e2)
19285       eps2der=eij*eps3rt
19286       eps3der=eij*eps2rt
19287       eij=eij*eps2rt*eps3rt
19288
19289       sigder=-sig/sigsq
19290       e1=e1*eps1*eps2rt**2*eps3rt**2
19291       ed=-expon*(e1+eij)/ljd
19292       sigder=ed*sigder
19293       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
19294       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
19295       eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
19296            -2.0D0*alf12*eps3der+sigder*sigsq_om12
19297       else if (rij.lt.ssxm) then
19298       havebond=.true.
19299       ssd=rij-ssXs
19300       eij=ssA*ssd*ssd+ssB*ssd+ssC
19301
19302       ed=2*akcm*ssd+akct*deltat12
19303       pom1=akct*ssd
19304       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
19305       eom1=-2*akth*deltat1-pom1-om2*pom2
19306       eom2= 2*akth*deltat2+pom1-om1*pom2
19307       eom12=pom2
19308       else
19309       omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
19310
19311       d_ssxm(1)=0.5D0*akct/ssA
19312       d_ssxm(2)=-d_ssxm(1)
19313       d_ssxm(3)=0.0D0
19314
19315       d_ljxm(1)=sig0ij/sqrt(sigsq**3)
19316       d_ljxm(2)=d_ljxm(1)*sigsq_om2
19317       d_ljxm(3)=d_ljxm(1)*sigsq_om12
19318       d_ljxm(1)=d_ljxm(1)*sigsq_om1
19319
19320 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
19321       xm=0.5d0*(ssxm+ljxm)
19322       do k=1,3
19323         d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
19324       enddo
19325       if (rij.lt.xm) then
19326         havebond=.true.
19327         ssm=ssC-0.25D0*ssB*ssB/ssA
19328         d_ssm(1)=0.5D0*akct*ssB/ssA
19329         d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
19330         d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
19331         d_ssm(3)=omega
19332         f1=(rij-xm)/(ssxm-xm)
19333         f2=(rij-ssxm)/(xm-ssxm)
19334         h1=h_base(f1,hd1)
19335         h2=h_base(f2,hd2)
19336         eij=ssm*h1+Ht*h2
19337         delta_inv=1.0d0/(xm-ssxm)
19338         deltasq_inv=delta_inv*delta_inv
19339         fac=ssm*hd1-Ht*hd2
19340         fac1=deltasq_inv*fac*(xm-rij)
19341         fac2=deltasq_inv*fac*(rij-ssxm)
19342         ed=delta_inv*(Ht*hd2-ssm*hd1)
19343         eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
19344         eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
19345         eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
19346       else
19347         havebond=.false.
19348         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
19349         d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
19350         d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
19351         d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
19352              alf12/eps3rt)
19353         d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
19354         f1=(rij-ljxm)/(xm-ljxm)
19355         f2=(rij-xm)/(ljxm-xm)
19356         h1=h_base(f1,hd1)
19357         h2=h_base(f2,hd2)
19358         eij=Ht*h1+ljm*h2
19359         delta_inv=1.0d0/(ljxm-xm)
19360         deltasq_inv=delta_inv*delta_inv
19361         fac=Ht*hd1-ljm*hd2
19362         fac1=deltasq_inv*fac*(ljxm-rij)
19363         fac2=deltasq_inv*fac*(rij-xm)
19364         ed=delta_inv*(ljm*hd2-Ht*hd1)
19365         eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
19366         eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
19367         eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
19368       endif
19369 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
19370
19371 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
19372 !$$$        ssd=rij-ssXs
19373 !$$$        ljd=rij-ljXs
19374 !$$$        fac1=rij-ljxm
19375 !$$$        fac2=rij-ssxm
19376 !$$$
19377 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
19378 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
19379 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
19380 !$$$
19381 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
19382 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
19383 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
19384 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
19385 !$$$        d_ssm(3)=omega
19386 !$$$
19387 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
19388 !$$$        do k=1,3
19389 !$$$          d_ljm(k)=ljm*d_ljB(k)
19390 !$$$        enddo
19391 !$$$        ljm=ljm*ljB
19392 !$$$
19393 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
19394 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
19395 !$$$        d_ss(2)=akct*ssd
19396 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
19397 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
19398 !$$$        d_ss(3)=omega
19399 !$$$
19400 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
19401 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
19402 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
19403 !$$$        do k=1,3
19404 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
19405 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
19406 !$$$        enddo
19407 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
19408 !$$$
19409 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
19410 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
19411 !$$$        h1=h_base(f1,hd1)
19412 !$$$        h2=h_base(f2,hd2)
19413 !$$$        eij=ss*h1+ljf*h2
19414 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
19415 !$$$        deltasq_inv=delta_inv*delta_inv
19416 !$$$        fac=ljf*hd2-ss*hd1
19417 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
19418 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
19419 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
19420 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
19421 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
19422 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
19423 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
19424 !$$$
19425 !$$$        havebond=.false.
19426 !$$$        if (ed.gt.0.0d0) havebond=.true.
19427 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
19428
19429       endif
19430
19431       if (havebond) then
19432 !#ifndef CLUST
19433 !#ifndef WHAM
19434 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
19435 !          write(iout,'(a15,f12.2,f8.1,2i5)')
19436 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
19437 !        endif
19438 !#endif
19439 !#endif
19440       dyn_ssbond_ij(i,j)=eij
19441       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
19442       dyn_ssbond_ij(i,j)=1.0d300
19443 !#ifndef CLUST
19444 !#ifndef WHAM
19445 !        write(iout,'(a15,f12.2,f8.1,2i5)')
19446 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
19447 !#endif
19448 !#endif
19449       endif
19450
19451 !-------TESTING CODE
19452 !el      if (checkstop) then
19453       if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
19454            "CHECKSTOP",rij,eij,ed
19455       echeck(jcheck)=eij
19456 !el      endif
19457       enddo
19458       if (checkstop) then
19459       write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
19460       endif
19461       enddo
19462       if (checkstop) then
19463       transgrad=.true.
19464       checkstop=.false.
19465       endif
19466 !-------END TESTING CODE
19467
19468       do k=1,3
19469       dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
19470       dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
19471       enddo
19472       do k=1,3
19473       gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
19474       enddo
19475       do k=1,3
19476       gvdwx(k,i)=gvdwx(k,i)-gg(k) &
19477            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
19478            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
19479       gvdwx(k,j)=gvdwx(k,j)+gg(k) &
19480            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
19481            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
19482       enddo
19483 !grad      do k=i,j-1
19484 !grad        do l=1,3
19485 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
19486 !grad        enddo
19487 !grad      enddo
19488
19489       do l=1,3
19490       gvdwc(l,i)=gvdwc(l,i)-gg(l)
19491       gvdwc(l,j)=gvdwc(l,j)+gg(l)
19492       enddo
19493
19494       return
19495       end subroutine dyn_ssbond_ene
19496 !--------------------------------------------------------------------------
19497        subroutine triple_ssbond_ene(resi,resj,resk,eij)
19498 !      implicit none
19499 !      Includes
19500       use calc_data
19501       use comm_sschecks
19502 !      include 'DIMENSIONS'
19503 !      include 'COMMON.SBRIDGE'
19504 !      include 'COMMON.CHAIN'
19505 !      include 'COMMON.DERIV'
19506 !      include 'COMMON.LOCAL'
19507 !      include 'COMMON.INTERACT'
19508 !      include 'COMMON.VAR'
19509 !      include 'COMMON.IOUNITS'
19510 !      include 'COMMON.CALC'
19511 #ifndef CLUST
19512 #ifndef WHAM
19513        use MD_data
19514 !      include 'COMMON.MD'
19515 !      use MD, only: totT,t_bath
19516 #endif
19517 #endif
19518       double precision h_base
19519       external h_base
19520
19521 !c     Input arguments
19522       integer resi,resj,resk,m,itypi,itypj,itypk
19523
19524 !c     Output arguments
19525       double precision eij,eij1,eij2,eij3
19526
19527 !c     Local variables
19528       logical havebond
19529 !c      integer itypi,itypj,k,l
19530       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
19531       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
19532       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
19533       double precision sig0ij,ljd,sig,fac,e1,e2
19534       double precision dcosom1(3),dcosom2(3),ed
19535       double precision pom1,pom2
19536       double precision ljA,ljB,ljXs
19537       double precision d_ljB(1:3)
19538       double precision ssA,ssB,ssC,ssXs
19539       double precision ssxm,ljxm,ssm,ljm
19540       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
19541       eij=0.0
19542       if (dtriss.eq.0) return
19543       i=resi
19544       j=resj
19545       k=resk
19546 !C      write(iout,*) resi,resj,resk
19547       itypi=itype(i,1)
19548       dxi=dc_norm(1,nres+i)
19549       dyi=dc_norm(2,nres+i)
19550       dzi=dc_norm(3,nres+i)
19551       dsci_inv=vbld_inv(i+nres)
19552       xi=c(1,nres+i)
19553       yi=c(2,nres+i)
19554       zi=c(3,nres+i)
19555       call to_box(xi,yi,zi)
19556       itypj=itype(j,1)
19557       xj=c(1,nres+j)
19558       yj=c(2,nres+j)
19559       zj=c(3,nres+j)
19560       call to_box(xj,yj,zj)
19561       dxj=dc_norm(1,nres+j)
19562       dyj=dc_norm(2,nres+j)
19563       dzj=dc_norm(3,nres+j)
19564       dscj_inv=vbld_inv(j+nres)
19565       itypk=itype(k,1)
19566       xk=c(1,nres+k)
19567       yk=c(2,nres+k)
19568       zk=c(3,nres+k)
19569        call to_box(xk,yk,zk)
19570       dxk=dc_norm(1,nres+k)
19571       dyk=dc_norm(2,nres+k)
19572       dzk=dc_norm(3,nres+k)
19573       dscj_inv=vbld_inv(k+nres)
19574       xij=xj-xi
19575       xik=xk-xi
19576       xjk=xk-xj
19577       yij=yj-yi
19578       yik=yk-yi
19579       yjk=yk-yj
19580       zij=zj-zi
19581       zik=zk-zi
19582       zjk=zk-zj
19583       rrij=(xij*xij+yij*yij+zij*zij)
19584       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
19585       rrik=(xik*xik+yik*yik+zik*zik)
19586       rik=dsqrt(rrik)
19587       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
19588       rjk=dsqrt(rrjk)
19589 !C there are three combination of distances for each trisulfide bonds
19590 !C The first case the ith atom is the center
19591 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
19592 !C distance y is second distance the a,b,c,d are parameters derived for
19593 !C this problem d parameter was set as a penalty currenlty set to 1.
19594       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
19595       eij1=0.0d0
19596       else
19597       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
19598       endif
19599 !C second case jth atom is center
19600       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
19601       eij2=0.0d0
19602       else
19603       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
19604       endif
19605 !C the third case kth atom is the center
19606       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
19607       eij3=0.0d0
19608       else
19609       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
19610       endif
19611 !C      eij2=0.0
19612 !C      eij3=0.0
19613 !C      eij1=0.0
19614       eij=eij1+eij2+eij3
19615 !C      write(iout,*)i,j,k,eij
19616 !C The energy penalty calculated now time for the gradient part
19617 !C derivative over rij
19618       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19619       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
19620           gg(1)=xij*fac/rij
19621           gg(2)=yij*fac/rij
19622           gg(3)=zij*fac/rij
19623       do m=1,3
19624       gvdwx(m,i)=gvdwx(m,i)-gg(m)
19625       gvdwx(m,j)=gvdwx(m,j)+gg(m)
19626       enddo
19627
19628       do l=1,3
19629       gvdwc(l,i)=gvdwc(l,i)-gg(l)
19630       gvdwc(l,j)=gvdwc(l,j)+gg(l)
19631       enddo
19632 !C now derivative over rik
19633       fac=-eij1**2/dtriss* &
19634       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
19635       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19636           gg(1)=xik*fac/rik
19637           gg(2)=yik*fac/rik
19638           gg(3)=zik*fac/rik
19639       do m=1,3
19640       gvdwx(m,i)=gvdwx(m,i)-gg(m)
19641       gvdwx(m,k)=gvdwx(m,k)+gg(m)
19642       enddo
19643       do l=1,3
19644       gvdwc(l,i)=gvdwc(l,i)-gg(l)
19645       gvdwc(l,k)=gvdwc(l,k)+gg(l)
19646       enddo
19647 !C now derivative over rjk
19648       fac=-eij2**2/dtriss* &
19649       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
19650       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
19651           gg(1)=xjk*fac/rjk
19652           gg(2)=yjk*fac/rjk
19653           gg(3)=zjk*fac/rjk
19654       do m=1,3
19655       gvdwx(m,j)=gvdwx(m,j)-gg(m)
19656       gvdwx(m,k)=gvdwx(m,k)+gg(m)
19657       enddo
19658       do l=1,3
19659       gvdwc(l,j)=gvdwc(l,j)-gg(l)
19660       gvdwc(l,k)=gvdwc(l,k)+gg(l)
19661       enddo
19662       return
19663       end subroutine triple_ssbond_ene
19664
19665
19666
19667 !-----------------------------------------------------------------------------
19668       real(kind=8) function h_base(x,deriv)
19669 !     A smooth function going 0->1 in range [0,1]
19670 !     It should NOT be called outside range [0,1], it will not work there.
19671       implicit none
19672
19673 !     Input arguments
19674       real(kind=8) :: x
19675
19676 !     Output arguments
19677       real(kind=8) :: deriv
19678
19679 !     Local variables
19680       real(kind=8) :: xsq
19681
19682
19683 !     Two parabolas put together.  First derivative zero at extrema
19684 !$$$      if (x.lt.0.5D0) then
19685 !$$$        h_base=2.0D0*x*x
19686 !$$$        deriv=4.0D0*x
19687 !$$$      else
19688 !$$$        deriv=1.0D0-x
19689 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
19690 !$$$        deriv=4.0D0*deriv
19691 !$$$      endif
19692
19693 !     Third degree polynomial.  First derivative zero at extrema
19694       h_base=x*x*(3.0d0-2.0d0*x)
19695       deriv=6.0d0*x*(1.0d0-x)
19696
19697 !     Fifth degree polynomial.  First and second derivatives zero at extrema
19698 !$$$      xsq=x*x
19699 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
19700 !$$$      deriv=x-1.0d0
19701 !$$$      deriv=deriv*deriv
19702 !$$$      deriv=30.0d0*xsq*deriv
19703
19704       return
19705       end function h_base
19706 !-----------------------------------------------------------------------------
19707       subroutine dyn_set_nss
19708 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
19709 !      implicit none
19710       use MD_data, only: totT,t_bath
19711 !     Includes
19712 !      include 'DIMENSIONS'
19713 #ifdef MPI
19714       include "mpif.h"
19715 #endif
19716 !      include 'COMMON.SBRIDGE'
19717 !      include 'COMMON.CHAIN'
19718 !      include 'COMMON.IOUNITS'
19719 !      include 'COMMON.SETUP'
19720 !      include 'COMMON.MD'
19721 !     Local variables
19722       real(kind=8) :: emin
19723       integer :: i,j,imin,ierr
19724       integer :: diff,allnss,newnss
19725       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19726             newihpb,newjhpb
19727       logical :: found
19728       integer,dimension(0:nfgtasks) :: i_newnss
19729       integer,dimension(0:nfgtasks) :: displ
19730       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
19731       integer :: g_newnss
19732
19733       allnss=0
19734       do i=1,nres-1
19735       do j=i+1,nres
19736         if (dyn_ssbond_ij(i,j).lt.1.0d300) then
19737           allnss=allnss+1
19738           allflag(allnss)=0
19739           allihpb(allnss)=i
19740           alljhpb(allnss)=j
19741         endif
19742       enddo
19743       enddo
19744
19745 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19746
19747  1    emin=1.0d300
19748       do i=1,allnss
19749       if (allflag(i).eq.0 .and. &
19750            dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
19751         emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
19752         imin=i
19753       endif
19754       enddo
19755       if (emin.lt.1.0d300) then
19756       allflag(imin)=1
19757       do i=1,allnss
19758         if (allflag(i).eq.0 .and. &
19759              (allihpb(i).eq.allihpb(imin) .or. &
19760              alljhpb(i).eq.allihpb(imin) .or. &
19761              allihpb(i).eq.alljhpb(imin) .or. &
19762              alljhpb(i).eq.alljhpb(imin))) then
19763           allflag(i)=-1
19764         endif
19765       enddo
19766       goto 1
19767       endif
19768
19769 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
19770
19771       newnss=0
19772       do i=1,allnss
19773       if (allflag(i).eq.1) then
19774         newnss=newnss+1
19775         newihpb(newnss)=allihpb(i)
19776         newjhpb(newnss)=alljhpb(i)
19777       endif
19778       enddo
19779
19780 #ifdef MPI
19781       if (nfgtasks.gt.1)then
19782
19783       call MPI_Reduce(newnss,g_newnss,1,&
19784         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
19785       call MPI_Gather(newnss,1,MPI_INTEGER,&
19786                   i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
19787       displ(0)=0
19788       do i=1,nfgtasks-1,1
19789         displ(i)=i_newnss(i-1)+displ(i-1)
19790       enddo
19791       call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
19792                    g_newihpb,i_newnss,displ,MPI_INTEGER,&
19793                    king,FG_COMM,IERR)
19794       call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
19795                    g_newjhpb,i_newnss,displ,MPI_INTEGER,&
19796                    king,FG_COMM,IERR)
19797       if(fg_rank.eq.0) then
19798 !         print *,'g_newnss',g_newnss
19799 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
19800 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
19801        newnss=g_newnss
19802        do i=1,newnss
19803         newihpb(i)=g_newihpb(i)
19804         newjhpb(i)=g_newjhpb(i)
19805        enddo
19806       endif
19807       endif
19808 #endif
19809
19810       diff=newnss-nss
19811
19812 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
19813 !       print *,newnss,nss,maxdim
19814       do i=1,nss
19815       found=.false.
19816 !        print *,newnss
19817       do j=1,newnss
19818 !!          print *,j
19819         if (idssb(i).eq.newihpb(j) .and. &
19820              jdssb(i).eq.newjhpb(j)) found=.true.
19821       enddo
19822 #if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
19823 !        write(iout,*) "found",found,i,j
19824       if (.not.found.and.fg_rank.eq.0) &
19825           write(iout,'(a15,f12.2,f8.1,2i5)') &
19826            "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
19827 #endif
19828       enddo
19829
19830       do i=1,newnss
19831       found=.false.
19832       do j=1,nss
19833 !          print *,i,j
19834         if (newihpb(i).eq.idssb(j) .and. &
19835              newjhpb(i).eq.jdssb(j)) found=.true.
19836       enddo
19837 #if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
19838 !        write(iout,*) "found",found,i,j
19839       if (.not.found.and.fg_rank.eq.0) &
19840           write(iout,'(a15,f12.2,f8.1,2i5)') &
19841            "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
19842 #endif
19843       enddo
19844 !#if .not. defined(WHAM_RUN) && .not. defined(CLUSTER)
19845       nss=newnss
19846       do i=1,nss
19847       idssb(i)=newihpb(i)
19848       jdssb(i)=newjhpb(i)
19849       enddo
19850 !#else
19851 !      nss=0
19852 !#endif
19853
19854       return
19855       end subroutine dyn_set_nss
19856 ! Lipid transfer energy function
19857       subroutine Eliptransfer(eliptran)
19858 !C this is done by Adasko
19859 !C      print *,"wchodze"
19860 !C structure of box:
19861 !C      water
19862 !C--bordliptop-- buffore starts
19863 !C--bufliptop--- here true lipid starts
19864 !C      lipid
19865 !C--buflipbot--- lipid ends buffore starts
19866 !C--bordlipbot--buffore ends
19867       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
19868       integer :: i
19869       eliptran=0.0
19870 !      print *, "I am in eliptran"
19871       do i=ilip_start,ilip_end
19872 !C       do i=1,1
19873       if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
19874        cycle
19875
19876       positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
19877       if (positi.le.0.0) positi=positi+boxzsize
19878 !C        print *,i
19879 !C first for peptide groups
19880 !c for each residue check if it is in lipid or lipid water border area
19881        if ((positi.gt.bordlipbot)  &
19882       .and.(positi.lt.bordliptop)) then
19883 !C the energy transfer exist
19884       if (positi.lt.buflipbot) then
19885 !C what fraction I am in
19886        fracinbuf=1.0d0-      &
19887            ((positi-bordlipbot)/lipbufthick)
19888 !C lipbufthick is thickenes of lipid buffore
19889        sslip=sscalelip(fracinbuf)
19890        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19891        eliptran=eliptran+sslip*pepliptran
19892        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19893        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19894 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19895
19896 !C        print *,"doing sccale for lower part"
19897 !C         print *,i,sslip,fracinbuf,ssgradlip
19898       elseif (positi.gt.bufliptop) then
19899        fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
19900        sslip=sscalelip(fracinbuf)
19901        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19902        eliptran=eliptran+sslip*pepliptran
19903        gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
19904        gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
19905 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
19906 !C          print *, "doing sscalefor top part"
19907 !C         print *,i,sslip,fracinbuf,ssgradlip
19908       else
19909        eliptran=eliptran+pepliptran
19910 !C         print *,"I am in true lipid"
19911       endif
19912 !C       else
19913 !C       eliptran=elpitran+0.0 ! I am in water
19914        endif
19915        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
19916        enddo
19917 ! here starts the side chain transfer
19918        do i=ilip_start,ilip_end
19919       if (itype(i,1).eq.ntyp1) cycle
19920       positi=(mod(c(3,i+nres),boxzsize))
19921       if (positi.le.0) positi=positi+boxzsize
19922 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19923 !c for each residue check if it is in lipid or lipid water border area
19924 !C       respos=mod(c(3,i+nres),boxzsize)
19925 !C       print *,positi,bordlipbot,buflipbot
19926        if ((positi.gt.bordlipbot) &
19927        .and.(positi.lt.bordliptop)) then
19928 !C the energy transfer exist
19929       if (positi.lt.buflipbot) then
19930        fracinbuf=1.0d0-   &
19931          ((positi-bordlipbot)/lipbufthick)
19932 !C lipbufthick is thickenes of lipid buffore
19933        sslip=sscalelip(fracinbuf)
19934        ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
19935        eliptran=eliptran+sslip*liptranene(itype(i,1))
19936        gliptranx(3,i)=gliptranx(3,i) &
19937       +ssgradlip*liptranene(itype(i,1))
19938        gliptranc(3,i-1)= gliptranc(3,i-1) &
19939       +ssgradlip*liptranene(itype(i,1))
19940 !C         print *,"doing sccale for lower part"
19941       elseif (positi.gt.bufliptop) then
19942        fracinbuf=1.0d0-  &
19943       ((bordliptop-positi)/lipbufthick)
19944        sslip=sscalelip(fracinbuf)
19945        ssgradlip=sscagradlip(fracinbuf)/lipbufthick
19946        eliptran=eliptran+sslip*liptranene(itype(i,1))
19947        gliptranx(3,i)=gliptranx(3,i)  &
19948        +ssgradlip*liptranene(itype(i,1))
19949        gliptranc(3,i-1)= gliptranc(3,i-1) &
19950       +ssgradlip*liptranene(itype(i,1))
19951 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19952       else
19953        eliptran=eliptran+liptranene(itype(i,1))
19954 !C         print *,"I am in true lipid"
19955       endif
19956       endif ! if in lipid or buffor
19957 !C       else
19958 !C       eliptran=elpitran+0.0 ! I am in water
19959       if (energy_dec) write(iout,*) i,"eliptran=",eliptran
19960        enddo
19961        return
19962        end  subroutine Eliptransfer
19963 !----------------------------------NANO FUNCTIONS
19964 !C-----------------------------------------------------------------------
19965 !C-----------------------------------------------------------
19966 !C This subroutine is to mimic the histone like structure but as well can be
19967 !C utilizet to nanostructures (infinit) small modification has to be used to
19968 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19969 !C gradient has to be modified at the ends
19970 !C The energy function is Kihara potential
19971 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19972 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19973 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19974 !C simple Kihara potential
19975       subroutine calctube(Etube)
19976       real(kind=8),dimension(3) :: vectube
19977       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19978        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
19979        sc_aa_tube,sc_bb_tube
19980       integer :: i,j,iti
19981       Etube=0.0d0
19982       do i=itube_start,itube_end
19983       enetube(i)=0.0d0
19984       enetube(i+nres)=0.0d0
19985       enddo
19986 !C first we calculate the distance from tube center
19987 !C for UNRES
19988        do i=itube_start,itube_end
19989 !C lets ommit dummy atoms for now
19990        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19991 !C now calculate distance from center of tube and direction vectors
19992       xmin=boxxsize
19993       ymin=boxysize
19994 ! Find minimum distance in periodic box
19995       do j=-1,1
19996        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19997        vectube(1)=vectube(1)+boxxsize*j
19998        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19999        vectube(2)=vectube(2)+boxysize*j
20000        xminact=abs(vectube(1)-tubecenter(1))
20001        yminact=abs(vectube(2)-tubecenter(2))
20002          if (xmin.gt.xminact) then
20003           xmin=xminact
20004           xtemp=vectube(1)
20005          endif
20006          if (ymin.gt.yminact) then
20007            ymin=yminact
20008            ytemp=vectube(2)
20009           endif
20010        enddo
20011       vectube(1)=xtemp
20012       vectube(2)=ytemp
20013       vectube(1)=vectube(1)-tubecenter(1)
20014       vectube(2)=vectube(2)-tubecenter(2)
20015
20016 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20017 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20018
20019 !C as the tube is infinity we do not calculate the Z-vector use of Z
20020 !C as chosen axis
20021       vectube(3)=0.0d0
20022 !C now calculte the distance
20023        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20024 !C now normalize vector
20025       vectube(1)=vectube(1)/tub_r
20026       vectube(2)=vectube(2)/tub_r
20027 !C calculte rdiffrence between r and r0
20028       rdiff=tub_r-tubeR0
20029 !C and its 6 power
20030       rdiff6=rdiff**6.0d0
20031 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20032        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
20033 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
20034 !C       print *,rdiff,rdiff6,pep_aa_tube
20035 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20036 !C now we calculate gradient
20037        fac=(-12.0d0*pep_aa_tube/rdiff6- &
20038           6.0d0*pep_bb_tube)/rdiff6/rdiff
20039 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
20040 !C     &rdiff,fac
20041 !C now direction of gg_tube vector
20042       do j=1,3
20043       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
20044       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
20045       enddo
20046       enddo
20047 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
20048 !C        print *,gg_tube(1,0),"TU"
20049
20050
20051        do i=itube_start,itube_end
20052 !C Lets not jump over memory as we use many times iti
20053        iti=itype(i,1)
20054 !C lets ommit dummy atoms for now
20055        if ((iti.eq.ntyp1)  &
20056 !C in UNRES uncomment the line below as GLY has no side-chain...
20057 !C      .or.(iti.eq.10)
20058       ) cycle
20059       xmin=boxxsize
20060       ymin=boxysize
20061       do j=-1,1
20062        vectube(1)=mod((c(1,i+nres)),boxxsize)
20063        vectube(1)=vectube(1)+boxxsize*j
20064        vectube(2)=mod((c(2,i+nres)),boxysize)
20065        vectube(2)=vectube(2)+boxysize*j
20066
20067        xminact=abs(vectube(1)-tubecenter(1))
20068        yminact=abs(vectube(2)-tubecenter(2))
20069          if (xmin.gt.xminact) then
20070           xmin=xminact
20071           xtemp=vectube(1)
20072          endif
20073          if (ymin.gt.yminact) then
20074            ymin=yminact
20075            ytemp=vectube(2)
20076           endif
20077        enddo
20078       vectube(1)=xtemp
20079       vectube(2)=ytemp
20080 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
20081 !C     &     tubecenter(2)
20082       vectube(1)=vectube(1)-tubecenter(1)
20083       vectube(2)=vectube(2)-tubecenter(2)
20084
20085 !C as the tube is infinity we do not calculate the Z-vector use of Z
20086 !C as chosen axis
20087       vectube(3)=0.0d0
20088 !C now calculte the distance
20089        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20090 !C now normalize vector
20091       vectube(1)=vectube(1)/tub_r
20092       vectube(2)=vectube(2)/tub_r
20093
20094 !C calculte rdiffrence between r and r0
20095       rdiff=tub_r-tubeR0
20096 !C and its 6 power
20097       rdiff6=rdiff**6.0d0
20098 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20099        sc_aa_tube=sc_aa_tube_par(iti)
20100        sc_bb_tube=sc_bb_tube_par(iti)
20101        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20102        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
20103            6.0d0*sc_bb_tube/rdiff6/rdiff
20104 !C now direction of gg_tube vector
20105        do j=1,3
20106         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20107         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20108        enddo
20109       enddo
20110       do i=itube_start,itube_end
20111         Etube=Etube+enetube(i)+enetube(i+nres)
20112       enddo
20113 !C        print *,"ETUBE", etube
20114       return
20115       end subroutine calctube
20116 !C TO DO 1) add to total energy
20117 !C       2) add to gradient summation
20118 !C       3) add reading parameters (AND of course oppening of PARAM file)
20119 !C       4) add reading the center of tube
20120 !C       5) add COMMONs
20121 !C       6) add to zerograd
20122 !C       7) allocate matrices
20123
20124
20125 !C-----------------------------------------------------------------------
20126 !C-----------------------------------------------------------
20127 !C This subroutine is to mimic the histone like structure but as well can be
20128 !C utilizet to nanostructures (infinit) small modification has to be used to
20129 !C make it finite (z gradient at the ends has to be changes as well as the x,y
20130 !C gradient has to be modified at the ends
20131 !C The energy function is Kihara potential
20132 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
20133 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
20134 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
20135 !C simple Kihara potential
20136       subroutine calctube2(Etube)
20137           real(kind=8),dimension(3) :: vectube
20138       real(kind=8) :: Etube,xtemp,xminact,yminact,&
20139        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
20140        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
20141       integer:: i,j,iti
20142       Etube=0.0d0
20143       do i=itube_start,itube_end
20144       enetube(i)=0.0d0
20145       enetube(i+nres)=0.0d0
20146       enddo
20147 !C first we calculate the distance from tube center
20148 !C first sugare-phosphate group for NARES this would be peptide group
20149 !C for UNRES
20150        do i=itube_start,itube_end
20151 !C lets ommit dummy atoms for now
20152
20153        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
20154 !C now calculate distance from center of tube and direction vectors
20155 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20156 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
20157 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20158 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
20159       xmin=boxxsize
20160       ymin=boxysize
20161       do j=-1,1
20162        vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20163        vectube(1)=vectube(1)+boxxsize*j
20164        vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20165        vectube(2)=vectube(2)+boxysize*j
20166
20167        xminact=abs(vectube(1)-tubecenter(1))
20168        yminact=abs(vectube(2)-tubecenter(2))
20169          if (xmin.gt.xminact) then
20170           xmin=xminact
20171           xtemp=vectube(1)
20172          endif
20173          if (ymin.gt.yminact) then
20174            ymin=yminact
20175            ytemp=vectube(2)
20176           endif
20177        enddo
20178       vectube(1)=xtemp
20179       vectube(2)=ytemp
20180       vectube(1)=vectube(1)-tubecenter(1)
20181       vectube(2)=vectube(2)-tubecenter(2)
20182
20183 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20184 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20185
20186 !C as the tube is infinity we do not calculate the Z-vector use of Z
20187 !C as chosen axis
20188       vectube(3)=0.0d0
20189 !C now calculte the distance
20190        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20191 !C now normalize vector
20192       vectube(1)=vectube(1)/tub_r
20193       vectube(2)=vectube(2)/tub_r
20194 !C calculte rdiffrence between r and r0
20195       rdiff=tub_r-tubeR0
20196 !C and its 6 power
20197       rdiff6=rdiff**6.0d0
20198 !C THIS FRAGMENT MAKES TUBE FINITE
20199       positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
20200       if (positi.le.0) positi=positi+boxzsize
20201 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
20202 !c for each residue check if it is in lipid or lipid water border area
20203 !C       respos=mod(c(3,i+nres),boxzsize)
20204 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
20205        if ((positi.gt.bordtubebot)  &
20206       .and.(positi.lt.bordtubetop)) then
20207 !C the energy transfer exist
20208       if (positi.lt.buftubebot) then
20209        fracinbuf=1.0d0-  &
20210          ((positi-bordtubebot)/tubebufthick)
20211 !C lipbufthick is thickenes of lipid buffore
20212        sstube=sscalelip(fracinbuf)
20213        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
20214 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
20215        enetube(i)=enetube(i)+sstube*tubetranenepep
20216 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20217 !C     &+ssgradtube*tubetranene(itype(i,1))
20218 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20219 !C     &+ssgradtube*tubetranene(itype(i,1))
20220 !C         print *,"doing sccale for lower part"
20221       elseif (positi.gt.buftubetop) then
20222        fracinbuf=1.0d0-  &
20223       ((bordtubetop-positi)/tubebufthick)
20224        sstube=sscalelip(fracinbuf)
20225        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
20226        enetube(i)=enetube(i)+sstube*tubetranenepep
20227 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20228 !C     &+ssgradtube*tubetranene(itype(i,1))
20229 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20230 !C     &+ssgradtube*tubetranene(itype(i,1))
20231 !C          print *, "doing sscalefor top part",sslip,fracinbuf
20232       else
20233        sstube=1.0d0
20234        ssgradtube=0.0d0
20235        enetube(i)=enetube(i)+sstube*tubetranenepep
20236 !C         print *,"I am in true lipid"
20237       endif
20238       else
20239 !C          sstube=0.0d0
20240 !C          ssgradtube=0.0d0
20241       cycle
20242       endif ! if in lipid or buffor
20243
20244 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20245        enetube(i)=enetube(i)+sstube* &
20246       (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
20247 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
20248 !C       print *,rdiff,rdiff6,pep_aa_tube
20249 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20250 !C now we calculate gradient
20251        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
20252            6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
20253 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
20254 !C     &rdiff,fac
20255
20256 !C now direction of gg_tube vector
20257        do j=1,3
20258       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
20259       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
20260       enddo
20261        gg_tube(3,i)=gg_tube(3,i)  &
20262        +ssgradtube*enetube(i)/sstube/2.0d0
20263        gg_tube(3,i-1)= gg_tube(3,i-1)  &
20264        +ssgradtube*enetube(i)/sstube/2.0d0
20265
20266       enddo
20267 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
20268 !C        print *,gg_tube(1,0),"TU"
20269       do i=itube_start,itube_end
20270 !C Lets not jump over memory as we use many times iti
20271        iti=itype(i,1)
20272 !C lets ommit dummy atoms for now
20273        if ((iti.eq.ntyp1) &
20274 !!C in UNRES uncomment the line below as GLY has no side-chain...
20275          .or.(iti.eq.10) &
20276         ) cycle
20277         vectube(1)=c(1,i+nres)
20278         vectube(1)=mod(vectube(1),boxxsize)
20279         if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
20280         vectube(2)=c(2,i+nres)
20281         vectube(2)=mod(vectube(2),boxysize)
20282         if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
20283
20284       vectube(1)=vectube(1)-tubecenter(1)
20285       vectube(2)=vectube(2)-tubecenter(2)
20286 !C THIS FRAGMENT MAKES TUBE FINITE
20287       positi=(mod(c(3,i+nres),boxzsize))
20288       if (positi.le.0) positi=positi+boxzsize
20289 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
20290 !c for each residue check if it is in lipid or lipid water border area
20291 !C       respos=mod(c(3,i+nres),boxzsize)
20292 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
20293
20294        if ((positi.gt.bordtubebot)  &
20295       .and.(positi.lt.bordtubetop)) then
20296 !C the energy transfer exist
20297       if (positi.lt.buftubebot) then
20298        fracinbuf=1.0d0- &
20299           ((positi-bordtubebot)/tubebufthick)
20300 !C lipbufthick is thickenes of lipid buffore
20301        sstube=sscalelip(fracinbuf)
20302        ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
20303 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
20304        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
20305 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20306 !C     &+ssgradtube*tubetranene(itype(i,1))
20307 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20308 !C     &+ssgradtube*tubetranene(itype(i,1))
20309 !C         print *,"doing sccale for lower part"
20310       elseif (positi.gt.buftubetop) then
20311        fracinbuf=1.0d0- &
20312       ((bordtubetop-positi)/tubebufthick)
20313
20314        sstube=sscalelip(fracinbuf)
20315        ssgradtube=sscagradlip(fracinbuf)/tubebufthick
20316        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
20317 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
20318 !C     &+ssgradtube*tubetranene(itype(i,1))
20319 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
20320 !C     &+ssgradtube*tubetranene(itype(i,1))
20321 !C          print *, "doing sscalefor top part",sslip,fracinbuf
20322       else
20323        sstube=1.0d0
20324        ssgradtube=0.0d0
20325        enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
20326 !C         print *,"I am in true lipid"
20327       endif
20328       else
20329 !C          sstube=0.0d0
20330 !C          ssgradtube=0.0d0
20331       cycle
20332       endif ! if in lipid or buffor
20333 !CEND OF FINITE FRAGMENT
20334 !C as the tube is infinity we do not calculate the Z-vector use of Z
20335 !C as chosen axis
20336       vectube(3)=0.0d0
20337 !C now calculte the distance
20338        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20339 !C now normalize vector
20340       vectube(1)=vectube(1)/tub_r
20341       vectube(2)=vectube(2)/tub_r
20342 !C calculte rdiffrence between r and r0
20343       rdiff=tub_r-tubeR0
20344 !C and its 6 power
20345       rdiff6=rdiff**6.0d0
20346 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20347        sc_aa_tube=sc_aa_tube_par(iti)
20348        sc_bb_tube=sc_bb_tube_par(iti)
20349        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
20350                    *sstube+enetube(i+nres)
20351 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20352 !C now we calculate gradient
20353        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
20354           6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
20355 !C now direction of gg_tube vector
20356        do j=1,3
20357         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20358         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20359        enddo
20360        gg_tube_SC(3,i)=gg_tube_SC(3,i) &
20361        +ssgradtube*enetube(i+nres)/sstube
20362        gg_tube(3,i-1)= gg_tube(3,i-1) &
20363        +ssgradtube*enetube(i+nres)/sstube
20364
20365       enddo
20366       do i=itube_start,itube_end
20367         Etube=Etube+enetube(i)+enetube(i+nres)
20368       enddo
20369 !C        print *,"ETUBE", etube
20370       return
20371       end subroutine calctube2
20372 !=====================================================================================================================================
20373       subroutine calcnano(Etube)
20374       real(kind=8),dimension(3) :: vectube
20375
20376       real(kind=8) :: Etube,xtemp,xminact,yminact,&
20377        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
20378        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
20379        integer:: i,j,iti,r
20380
20381       Etube=0.0d0
20382 !      print *,itube_start,itube_end,"poczatek"
20383       do i=itube_start,itube_end
20384       enetube(i)=0.0d0
20385       enetube(i+nres)=0.0d0
20386       enddo
20387 !C first we calculate the distance from tube center
20388 !C first sugare-phosphate group for NARES this would be peptide group
20389 !C for UNRES
20390        do i=itube_start,itube_end
20391 !C lets ommit dummy atoms for now
20392        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
20393 !C now calculate distance from center of tube and direction vectors
20394       xmin=boxxsize
20395       ymin=boxysize
20396       zmin=boxzsize
20397
20398       do j=-1,1
20399        vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
20400        vectube(1)=vectube(1)+boxxsize*j
20401        vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
20402        vectube(2)=vectube(2)+boxysize*j
20403        vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
20404        vectube(3)=vectube(3)+boxzsize*j
20405
20406
20407        xminact=dabs(vectube(1)-tubecenter(1))
20408        yminact=dabs(vectube(2)-tubecenter(2))
20409        zminact=dabs(vectube(3)-tubecenter(3))
20410
20411          if (xmin.gt.xminact) then
20412           xmin=xminact
20413           xtemp=vectube(1)
20414          endif
20415          if (ymin.gt.yminact) then
20416            ymin=yminact
20417            ytemp=vectube(2)
20418           endif
20419          if (zmin.gt.zminact) then
20420            zmin=zminact
20421            ztemp=vectube(3)
20422           endif
20423        enddo
20424       vectube(1)=xtemp
20425       vectube(2)=ytemp
20426       vectube(3)=ztemp
20427
20428       vectube(1)=vectube(1)-tubecenter(1)
20429       vectube(2)=vectube(2)-tubecenter(2)
20430       vectube(3)=vectube(3)-tubecenter(3)
20431
20432 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
20433 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
20434 !C as the tube is infinity we do not calculate the Z-vector use of Z
20435 !C as chosen axis
20436 !C      vectube(3)=0.0d0
20437 !C now calculte the distance
20438        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20439 !C now normalize vector
20440       vectube(1)=vectube(1)/tub_r
20441       vectube(2)=vectube(2)/tub_r
20442       vectube(3)=vectube(3)/tub_r
20443 !C calculte rdiffrence between r and r0
20444       rdiff=tub_r-tubeR0
20445 !C and its 6 power
20446       rdiff6=rdiff**6.0d0
20447 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
20448        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
20449 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
20450 !C       print *,rdiff,rdiff6,pep_aa_tube
20451 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20452 !C now we calculate gradient
20453        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
20454           6.0d0*pep_bb_tube)/rdiff6/rdiff
20455 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
20456 !C     &rdiff,fac
20457        if (acavtubpep.eq.0.0d0) then
20458 !C go to 667
20459        enecavtube(i)=0.0
20460        faccav=0.0
20461        else
20462        denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
20463        enecavtube(i)=  &
20464       (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
20465       /denominator
20466        enecavtube(i)=0.0
20467        faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
20468       *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
20469       +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
20470       /denominator**2.0d0
20471 !C         faccav=0.0
20472 !C         fac=fac+faccav
20473 !C 667     continue
20474        endif
20475         if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
20476       do j=1,3
20477       gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
20478       gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
20479       enddo
20480       enddo
20481
20482        do i=itube_start,itube_end
20483       enecavtube(i)=0.0d0
20484 !C Lets not jump over memory as we use many times iti
20485        iti=itype(i,1)
20486 !C lets ommit dummy atoms for now
20487        if ((iti.eq.ntyp1) &
20488 !C in UNRES uncomment the line below as GLY has no side-chain...
20489 !C      .or.(iti.eq.10)
20490        ) cycle
20491       xmin=boxxsize
20492       ymin=boxysize
20493       zmin=boxzsize
20494       do j=-1,1
20495        vectube(1)=dmod((c(1,i+nres)),boxxsize)
20496        vectube(1)=vectube(1)+boxxsize*j
20497        vectube(2)=dmod((c(2,i+nres)),boxysize)
20498        vectube(2)=vectube(2)+boxysize*j
20499        vectube(3)=dmod((c(3,i+nres)),boxzsize)
20500        vectube(3)=vectube(3)+boxzsize*j
20501
20502
20503        xminact=dabs(vectube(1)-tubecenter(1))
20504        yminact=dabs(vectube(2)-tubecenter(2))
20505        zminact=dabs(vectube(3)-tubecenter(3))
20506
20507          if (xmin.gt.xminact) then
20508           xmin=xminact
20509           xtemp=vectube(1)
20510          endif
20511          if (ymin.gt.yminact) then
20512            ymin=yminact
20513            ytemp=vectube(2)
20514           endif
20515          if (zmin.gt.zminact) then
20516            zmin=zminact
20517            ztemp=vectube(3)
20518           endif
20519        enddo
20520       vectube(1)=xtemp
20521       vectube(2)=ytemp
20522       vectube(3)=ztemp
20523
20524 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
20525 !C     &     tubecenter(2)
20526       vectube(1)=vectube(1)-tubecenter(1)
20527       vectube(2)=vectube(2)-tubecenter(2)
20528       vectube(3)=vectube(3)-tubecenter(3)
20529 !C now calculte the distance
20530        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
20531 !C now normalize vector
20532       vectube(1)=vectube(1)/tub_r
20533       vectube(2)=vectube(2)/tub_r
20534       vectube(3)=vectube(3)/tub_r
20535
20536 !C calculte rdiffrence between r and r0
20537       rdiff=tub_r-tubeR0
20538 !C and its 6 power
20539       rdiff6=rdiff**6.0d0
20540        sc_aa_tube=sc_aa_tube_par(iti)
20541        sc_bb_tube=sc_bb_tube_par(iti)
20542        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20543 !C       enetube(i+nres)=0.0d0
20544 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
20545 !C now we calculate gradient
20546        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
20547           6.0d0*sc_bb_tube/rdiff6/rdiff
20548 !C       fac=0.0
20549 !C now direction of gg_tube vector
20550 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
20551        if (acavtub(iti).eq.0.0d0) then
20552 !C go to 667
20553        enecavtube(i+nres)=0.0d0
20554        faccav=0.0d0
20555        else
20556        denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
20557        enecavtube(i+nres)=   &
20558       (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
20559       /denominator
20560 !C         enecavtube(i)=0.0
20561        faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
20562       *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
20563       +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
20564       /denominator**2.0d0
20565 !C         faccav=0.0
20566        fac=fac+faccav
20567 !C 667     continue
20568        endif
20569 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
20570 !C     &   enecavtube(i),faccav
20571 !C         print *,"licz=",
20572 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
20573 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
20574        do j=1,3
20575         gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
20576         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
20577        enddo
20578         if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
20579       enddo
20580
20581
20582
20583       do i=itube_start,itube_end
20584         Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
20585        +enecavtube(i+nres)
20586       enddo
20587 !        do i=1,20
20588 !         print *,"begin", i,"a"
20589 !         do r=1,10000
20590 !          rdiff=r/100.0d0
20591 !          rdiff6=rdiff**6.0d0
20592 !          sc_aa_tube=sc_aa_tube_par(i)
20593 !          sc_bb_tube=sc_bb_tube_par(i)
20594 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
20595 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
20596 !          enecavtube(i)=   &
20597 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
20598 !         /denominator
20599
20600 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
20601 !         enddo
20602 !         print *,"end",i,"a"
20603 !        enddo
20604 !C        print *,"ETUBE", etube
20605       return
20606       end subroutine calcnano
20607
20608 !===============================================
20609 !--------------------------------------------------------------------------------
20610 !C first for shielding is setting of function of side-chains
20611
20612        subroutine set_shield_fac2
20613        real(kind=8) :: div77_81=0.974996043d0, &
20614       div4_81=0.2222222222d0
20615        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
20616        scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
20617        short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
20618        sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
20619 !C the vector between center of side_chain and peptide group
20620        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
20621        pept_group,costhet_grad,cosphi_grad_long, &
20622        cosphi_grad_loc,pep_side_norm,side_calf_norm, &
20623        sh_frac_dist_grad,pep_side
20624       integer i,j,k
20625 !C      write(2,*) "ivec",ivec_start,ivec_end
20626       do i=1,nres
20627       fac_shield(i)=0.0d0
20628       ishield_list(i)=0
20629       do j=1,3
20630       grad_shield(j,i)=0.0d0
20631       enddo
20632       enddo
20633       do i=ivec_start,ivec_end
20634 !C      do i=1,nres-1
20635 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20636 !      ishield_list(i)=0
20637       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
20638 !Cif there two consequtive dummy atoms there is no peptide group between them
20639 !C the line below has to be changed for FGPROC>1
20640       VolumeTotal=0.0
20641       do k=1,nres
20642        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
20643        dist_pep_side=0.0
20644        dist_side_calf=0.0
20645        do j=1,3
20646 !C first lets set vector conecting the ithe side-chain with kth side-chain
20647       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
20648 !C      pep_side(j)=2.0d0
20649 !C and vector conecting the side-chain with its proper calfa
20650       side_calf(j)=c(j,k+nres)-c(j,k)
20651 !C      side_calf(j)=2.0d0
20652       pept_group(j)=c(j,i)-c(j,i+1)
20653 !C lets have their lenght
20654       dist_pep_side=pep_side(j)**2+dist_pep_side
20655       dist_side_calf=dist_side_calf+side_calf(j)**2
20656       dist_pept_group=dist_pept_group+pept_group(j)**2
20657       enddo
20658        dist_pep_side=sqrt(dist_pep_side)
20659        dist_pept_group=sqrt(dist_pept_group)
20660        dist_side_calf=sqrt(dist_side_calf)
20661       do j=1,3
20662       pep_side_norm(j)=pep_side(j)/dist_pep_side
20663       side_calf_norm(j)=dist_side_calf
20664       enddo
20665 !C now sscale fraction
20666        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
20667 !       print *,buff_shield,"buff",sh_frac_dist
20668 !C now sscale
20669       if (sh_frac_dist.le.0.0) cycle
20670 !C        print *,ishield_list(i),i
20671 !C If we reach here it means that this side chain reaches the shielding sphere
20672 !C Lets add him to the list for gradient
20673       ishield_list(i)=ishield_list(i)+1
20674 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
20675 !C this list is essential otherwise problem would be O3
20676       shield_list(ishield_list(i),i)=k
20677 !C Lets have the sscale value
20678       if (sh_frac_dist.gt.1.0) then
20679        scale_fac_dist=1.0d0
20680        do j=1,3
20681        sh_frac_dist_grad(j)=0.0d0
20682        enddo
20683       else
20684        scale_fac_dist=-sh_frac_dist*sh_frac_dist &
20685                   *(2.0d0*sh_frac_dist-3.0d0)
20686        fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
20687                    /dist_pep_side/buff_shield*0.5d0
20688        do j=1,3
20689        sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
20690 !C         sh_frac_dist_grad(j)=0.0d0
20691 !C         scale_fac_dist=1.0d0
20692 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
20693 !C     &                    sh_frac_dist_grad(j)
20694        enddo
20695       endif
20696 !C this is what is now we have the distance scaling now volume...
20697       short=short_r_sidechain(itype(k,1))
20698       long=long_r_sidechain(itype(k,1))
20699       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
20700       sinthet=short/dist_pep_side*costhet
20701 !      print *,"SORT",short,long,sinthet,costhet
20702 !C now costhet_grad
20703 !C       costhet=0.6d0
20704 !C       sinthet=0.8
20705        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
20706 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
20707 !C     &             -short/dist_pep_side**2/costhet)
20708 !C       costhet_fac=0.0d0
20709        do j=1,3
20710        costhet_grad(j)=costhet_fac*pep_side(j)
20711        enddo
20712 !C remember for the final gradient multiply costhet_grad(j)
20713 !C for side_chain by factor -2 !
20714 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
20715 !C pep_side0pept_group is vector multiplication
20716       pep_side0pept_group=0.0d0
20717       do j=1,3
20718       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
20719       enddo
20720       cosalfa=(pep_side0pept_group/ &
20721       (dist_pep_side*dist_side_calf))
20722       fac_alfa_sin=1.0d0-cosalfa**2
20723       fac_alfa_sin=dsqrt(fac_alfa_sin)
20724       rkprim=fac_alfa_sin*(long-short)+short
20725 !C      rkprim=short
20726
20727 !C now costhet_grad
20728        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
20729 !C       cosphi=0.6
20730        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
20731        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
20732          dist_pep_side**2)
20733 !C       sinphi=0.8
20734        do j=1,3
20735        cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
20736       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20737       *(long-short)/fac_alfa_sin*cosalfa/ &
20738       ((dist_pep_side*dist_side_calf))* &
20739       ((side_calf(j))-cosalfa* &
20740       ((pep_side(j)/dist_pep_side)*dist_side_calf))
20741 !C       cosphi_grad_long(j)=0.0d0
20742       cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
20743       *(long-short)/fac_alfa_sin*cosalfa &
20744       /((dist_pep_side*dist_side_calf))* &
20745       (pep_side(j)- &
20746       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
20747 !C       cosphi_grad_loc(j)=0.0d0
20748        enddo
20749 !C      print *,sinphi,sinthet
20750       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
20751                    /VSolvSphere_div
20752 !C     &                    *wshield
20753 !C now the gradient...
20754       do j=1,3
20755       grad_shield(j,i)=grad_shield(j,i) &
20756 !C gradient po skalowaniu
20757                  +(sh_frac_dist_grad(j)*VofOverlap &
20758 !C  gradient po costhet
20759           +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
20760       (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
20761           sinphi/sinthet*costhet*costhet_grad(j) &
20762          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20763       )*wshield
20764 !C grad_shield_side is Cbeta sidechain gradient
20765       grad_shield_side(j,ishield_list(i),i)=&
20766            (sh_frac_dist_grad(j)*-2.0d0&
20767            *VofOverlap&
20768           -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20769        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
20770           sinphi/sinthet*costhet*costhet_grad(j)&
20771          +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
20772           )*wshield
20773 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
20774 !            sinphi/sinthet,&
20775 !           +sinthet/sinphi,"HERE"
20776        grad_shield_loc(j,ishield_list(i),i)=   &
20777           scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
20778       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
20779           sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
20780            ))&
20781            *wshield
20782 !         print *,grad_shield_loc(j,ishield_list(i),i)
20783       enddo
20784       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
20785       enddo
20786       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
20787
20788 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
20789       enddo
20790       return
20791       end subroutine set_shield_fac2
20792 !----------------------------------------------------------------------------
20793 ! SOUBROUTINE FOR AFM
20794        subroutine AFMvel(Eafmforce)
20795        use MD_data, only:totTafm
20796       real(kind=8),dimension(3) :: diffafm
20797       real(kind=8) :: afmdist,Eafmforce
20798        integer :: i
20799 !C Only for check grad COMMENT if not used for checkgrad
20800 !C      totT=3.0d0
20801 !C--------------------------------------------------------
20802 !C      print *,"wchodze"
20803       afmdist=0.0d0
20804       Eafmforce=0.0d0
20805       do i=1,3
20806       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20807       afmdist=afmdist+diffafm(i)**2
20808       enddo
20809       afmdist=dsqrt(afmdist)
20810 !      totTafm=3.0
20811       Eafmforce=0.5d0*forceAFMconst &
20812       *(distafminit+totTafm*velAFMconst-afmdist)**2
20813 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
20814       do i=1,3
20815       gradafm(i,afmend-1)=-forceAFMconst* &
20816        (distafminit+totTafm*velAFMconst-afmdist) &
20817        *diffafm(i)/afmdist
20818       gradafm(i,afmbeg-1)=forceAFMconst* &
20819       (distafminit+totTafm*velAFMconst-afmdist) &
20820       *diffafm(i)/afmdist
20821       enddo
20822 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
20823       return
20824       end subroutine AFMvel
20825 !---------------------------------------------------------
20826        subroutine AFMforce(Eafmforce)
20827
20828       real(kind=8),dimension(3) :: diffafm
20829 !      real(kind=8) ::afmdist
20830       real(kind=8) :: afmdist,Eafmforce
20831       integer :: i
20832       afmdist=0.0d0
20833       Eafmforce=0.0d0
20834       do i=1,3
20835       diffafm(i)=c(i,afmend)-c(i,afmbeg)
20836       afmdist=afmdist+diffafm(i)**2
20837       enddo
20838       afmdist=dsqrt(afmdist)
20839 !      print *,afmdist,distafminit
20840       Eafmforce=-forceAFMconst*(afmdist-distafminit)
20841       do i=1,3
20842       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
20843       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
20844       enddo
20845 !C      print *,'AFM',Eafmforce
20846       return
20847       end subroutine AFMforce
20848
20849 !-----------------------------------------------------------------------------
20850 #ifdef WHAM
20851       subroutine read_ssHist
20852 !      implicit none
20853 !      Includes
20854 !      include 'DIMENSIONS'
20855 !      include "DIMENSIONS.FREE"
20856 !      include 'COMMON.FREE'
20857 !     Local variables
20858       integer :: i,j
20859       character(len=80) :: controlcard
20860
20861       do i=1,dyn_nssHist
20862       call card_concat(controlcard,.true.)
20863       read(controlcard,*) &
20864            dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
20865       enddo
20866
20867       return
20868       end subroutine read_ssHist
20869 #endif
20870 !-----------------------------------------------------------------------------
20871       integer function indmat(i,j)
20872 !el
20873 ! get the position of the jth ijth fragment of the chain coordinate system
20874 ! in the fromto array.
20875       integer :: i,j
20876
20877       indmat=((2*(nres-2)-i)*(i-1))/2+j-1
20878       return
20879       end function indmat
20880 !-----------------------------------------------------------------------------
20881       real(kind=8) function sigm(x)
20882 !el
20883        real(kind=8) :: x
20884       sigm=0.25d0*x
20885       return
20886       end function sigm
20887 !-----------------------------------------------------------------------------
20888 !-----------------------------------------------------------------------------
20889       subroutine alloc_ener_arrays
20890 !EL Allocation of arrays used by module energy
20891       use MD_data, only: mset
20892 !el local variables
20893       integer :: i,j
20894
20895       if(nres.lt.100) then
20896       maxconts=10*nres
20897       elseif(nres.lt.200) then
20898       maxconts=10*nres      ! Max. number of contacts per residue
20899       else
20900       maxconts=10*nres ! (maxconts=maxres/4)
20901       endif
20902       maxcont=100*nres      ! Max. number of SC contacts
20903       maxvar=6*nres      ! Max. number of variables
20904 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20905       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
20906 !----------------------
20907 ! arrays in subroutine init_int_table
20908 !el#ifdef MPI
20909 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
20910 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
20911 !el#endif
20912       allocate(nint_gr(nres))
20913       allocate(nscp_gr(nres))
20914       allocate(ielstart(nres))
20915       allocate(ielend(nres))
20916 !(maxres)
20917       allocate(istart(nres,maxint_gr))
20918       allocate(iend(nres,maxint_gr))
20919 !(maxres,maxint_gr)
20920       allocate(iscpstart(nres,maxint_gr))
20921       allocate(iscpend(nres,maxint_gr))
20922 !(maxres,maxint_gr)
20923       allocate(ielstart_vdw(nres))
20924       allocate(ielend_vdw(nres))
20925 !(maxres)
20926       allocate(nint_gr_nucl(nres))
20927       allocate(nscp_gr_nucl(nres))
20928       allocate(ielstart_nucl(nres))
20929       allocate(ielend_nucl(nres))
20930 !(maxres)
20931       allocate(istart_nucl(nres,maxint_gr))
20932       allocate(iend_nucl(nres,maxint_gr))
20933 !(maxres,maxint_gr)
20934       allocate(iscpstart_nucl(nres,maxint_gr))
20935       allocate(iscpend_nucl(nres,maxint_gr))
20936 !(maxres,maxint_gr)
20937       allocate(ielstart_vdw_nucl(nres))
20938       allocate(ielend_vdw_nucl(nres))
20939
20940       allocate(lentyp(0:nfgtasks-1))
20941 !(0:maxprocs-1)
20942 !----------------------
20943 ! commom.contacts
20944 !      common /contacts/
20945       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
20946       allocate(icont(2,maxcont))
20947 !(2,maxcont)
20948 !      common /contacts1/
20949       allocate(num_cont(0:nres+4))
20950 !(maxres)
20951       allocate(jcont(maxconts,nres))
20952 !(maxconts,maxres)
20953       allocate(facont(maxconts,nres))
20954 !(maxconts,maxres)
20955       allocate(gacont(3,maxconts,nres))
20956 !(3,maxconts,maxres)
20957 !      common /contacts_hb/
20958       allocate(gacontp_hb1(3,maxconts,nres))
20959       allocate(gacontp_hb2(3,maxconts,nres))
20960       allocate(gacontp_hb3(3,maxconts,nres))
20961       allocate(gacontm_hb1(3,maxconts,nres))
20962       allocate(gacontm_hb2(3,maxconts,nres))
20963       allocate(gacontm_hb3(3,maxconts,nres))
20964       allocate(gacont_hbr(3,maxconts,nres))
20965       allocate(grij_hb_cont(3,maxconts,nres))
20966         !(3,maxconts,maxres)
20967       allocate(facont_hb(maxconts,nres))
20968
20969       allocate(ees0p(maxconts,nres))
20970       allocate(ees0m(maxconts,nres))
20971       allocate(d_cont(maxconts,nres))
20972       allocate(ees0plist(maxconts,nres))
20973
20974 !(maxconts,maxres)
20975       allocate(num_cont_hb(nres))
20976 !(maxres)
20977       allocate(jcont_hb(maxconts,nres))
20978 !(maxconts,maxres)
20979 !      common /rotat/
20980       allocate(Ug(2,2,nres))
20981       allocate(Ugder(2,2,nres))
20982       allocate(Ug2(2,2,nres))
20983       allocate(Ug2der(2,2,nres))
20984 !(2,2,maxres)
20985       allocate(obrot(2,nres))
20986       allocate(obrot2(2,nres))
20987       allocate(obrot_der(2,nres))
20988       allocate(obrot2_der(2,nres))
20989 !(2,maxres)
20990 !      common /precomp1/
20991       allocate(mu(2,nres))
20992       allocate(muder(2,nres))
20993       allocate(Ub2(2,nres))
20994       Ub2(1,:)=0.0d0
20995       Ub2(2,:)=0.0d0
20996       allocate(Ub2der(2,nres))
20997       allocate(Ctobr(2,nres))
20998       allocate(Ctobrder(2,nres))
20999       allocate(Dtobr2(2,nres))
21000       allocate(Dtobr2der(2,nres))
21001 !(2,maxres)
21002       allocate(EUg(2,2,nres))
21003       allocate(EUgder(2,2,nres))
21004       allocate(CUg(2,2,nres))
21005       allocate(CUgder(2,2,nres))
21006       allocate(DUg(2,2,nres))
21007       allocate(Dugder(2,2,nres))
21008       allocate(DtUg2(2,2,nres))
21009       allocate(DtUg2der(2,2,nres))
21010 !(2,2,maxres)
21011 !      common /precomp2/
21012       allocate(Ug2Db1t(2,nres))
21013       allocate(Ug2Db1tder(2,nres))
21014       allocate(CUgb2(2,nres))
21015       allocate(CUgb2der(2,nres))
21016 !(2,maxres)
21017       allocate(EUgC(2,2,nres))
21018       allocate(EUgCder(2,2,nres))
21019       allocate(EUgD(2,2,nres))
21020       allocate(EUgDder(2,2,nres))
21021       allocate(DtUg2EUg(2,2,nres))
21022       allocate(Ug2DtEUg(2,2,nres))
21023 !(2,2,maxres)
21024       allocate(Ug2DtEUgder(2,2,2,nres))
21025       allocate(DtUg2EUgder(2,2,2,nres))
21026 !(2,2,2,maxres)
21027       allocate(b1(2,nres))      !(2,-maxtor:maxtor)
21028       allocate(b2(2,nres))      !(2,-maxtor:maxtor)
21029       allocate(b1tilde(2,nres)) !(2,-maxtor:maxtor)
21030       allocate(b2tilde(2,nres)) !(2,-maxtor:maxtor)
21031
21032       allocate(ctilde(2,2,nres))
21033       allocate(dtilde(2,2,nres)) !(2,2,-maxtor:maxtor)
21034       allocate(gtb1(2,nres))
21035       allocate(gtb2(2,nres))
21036       allocate(cc(2,2,nres))
21037       allocate(dd(2,2,nres))
21038       allocate(ee(2,2,nres))
21039       allocate(gtcc(2,2,nres))
21040       allocate(gtdd(2,2,nres))
21041       allocate(gtee(2,2,nres))
21042       allocate(gUb2(2,nres))
21043       allocate(gteUg(2,2,nres))
21044
21045 !      common /rotat_old/
21046       allocate(costab(nres))
21047       allocate(sintab(nres))
21048       allocate(costab2(nres))
21049       allocate(sintab2(nres))
21050 !(maxres)
21051 !      common /dipmat/
21052       allocate(a_chuj(2,2,maxconts,nres))
21053 !(2,2,maxconts,maxres)(maxconts=maxres/4)
21054       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
21055 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
21056 !      common /contdistrib/
21057       allocate(ncont_sent(nres))
21058       allocate(ncont_recv(nres))
21059
21060       allocate(iat_sent(nres))
21061 !(maxres)
21062       allocate(iint_sent(4,nres,nres))
21063       allocate(iint_sent_local(4,nres,nres))
21064 !(4,maxres,maxres)
21065       allocate(iturn3_sent(4,0:nres+4))
21066       allocate(iturn4_sent(4,0:nres+4))
21067       allocate(iturn3_sent_local(4,nres))
21068       allocate(iturn4_sent_local(4,nres))
21069 !(4,maxres)
21070       allocate(itask_cont_from(0:nfgtasks-1))
21071       allocate(itask_cont_to(0:nfgtasks-1))
21072 !(0:max_fg_procs-1)
21073
21074
21075
21076 !----------------------
21077 ! commom.deriv;
21078 !      common /derivat/
21079       allocate(dcdv(6,maxdim))
21080       allocate(dxdv(6,maxdim))
21081 !(6,maxdim)
21082       allocate(dxds(6,nres))
21083 !(6,maxres)
21084       allocate(gradx(3,-1:nres,0:2))
21085       allocate(gradc(3,-1:nres,0:2))
21086 !(3,maxres,2)
21087       allocate(gvdwx(3,-1:nres))
21088       allocate(gvdwc(3,-1:nres))
21089       allocate(gelc(3,-1:nres))
21090       allocate(gelc_long(3,-1:nres))
21091       allocate(gvdwpp(3,-1:nres))
21092       allocate(gvdwc_scpp(3,-1:nres))
21093       allocate(gradx_scp(3,-1:nres))
21094       allocate(gvdwc_scp(3,-1:nres))
21095       allocate(ghpbx(3,-1:nres))
21096       allocate(ghpbc(3,-1:nres))
21097       allocate(gradcorr(3,-1:nres))
21098       allocate(gradcorr_long(3,-1:nres))
21099       allocate(gradcorr5_long(3,-1:nres))
21100       allocate(gradcorr6_long(3,-1:nres))
21101       allocate(gcorr6_turn_long(3,-1:nres))
21102       allocate(gradxorr(3,-1:nres))
21103       allocate(gradcorr5(3,-1:nres))
21104       allocate(gradcorr6(3,-1:nres))
21105       allocate(gliptran(3,-1:nres))
21106       allocate(gliptranc(3,-1:nres))
21107       allocate(gliptranx(3,-1:nres))
21108       allocate(gshieldx(3,-1:nres))
21109       allocate(gshieldc(3,-1:nres))
21110       allocate(gshieldc_loc(3,-1:nres))
21111       allocate(gshieldx_ec(3,-1:nres))
21112       allocate(gshieldc_ec(3,-1:nres))
21113       allocate(gshieldc_loc_ec(3,-1:nres))
21114       allocate(gshieldx_t3(3,-1:nres))
21115       allocate(gshieldc_t3(3,-1:nres))
21116       allocate(gshieldc_loc_t3(3,-1:nres))
21117       allocate(gshieldx_t4(3,-1:nres))
21118       allocate(gshieldc_t4(3,-1:nres))
21119       allocate(gshieldc_loc_t4(3,-1:nres))
21120       allocate(gshieldx_ll(3,-1:nres))
21121       allocate(gshieldc_ll(3,-1:nres))
21122       allocate(gshieldc_loc_ll(3,-1:nres))
21123       allocate(grad_shield(3,-1:nres))
21124       allocate(gg_tube_sc(3,-1:nres))
21125       allocate(gg_tube(3,-1:nres))
21126       allocate(gradafm(3,-1:nres))
21127       allocate(gradb_nucl(3,-1:nres))
21128       allocate(gradbx_nucl(3,-1:nres))
21129       allocate(gvdwpsb1(3,-1:nres))
21130       allocate(gelpp(3,-1:nres))
21131       allocate(gvdwpsb(3,-1:nres))
21132       allocate(gelsbc(3,-1:nres))
21133       allocate(gelsbx(3,-1:nres))
21134       allocate(gvdwsbx(3,-1:nres))
21135       allocate(gvdwsbc(3,-1:nres))
21136       allocate(gsbloc(3,-1:nres))
21137       allocate(gsblocx(3,-1:nres))
21138       allocate(gradcorr_nucl(3,-1:nres))
21139       allocate(gradxorr_nucl(3,-1:nres))
21140       allocate(gradcorr3_nucl(3,-1:nres))
21141       allocate(gradxorr3_nucl(3,-1:nres))
21142       allocate(gvdwpp_nucl(3,-1:nres))
21143       allocate(gradpepcat(3,-1:nres))
21144       allocate(gradpepcatx(3,-1:nres))
21145       allocate(gradcatcat(3,-1:nres))
21146       allocate(gradnuclcat(3,-1:nres))
21147       allocate(gradnuclcatx(3,-1:nres))
21148 !(3,maxres)
21149       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
21150       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
21151 ! grad for shielding surroing
21152       allocate(gloc(0:maxvar,0:2))
21153       allocate(gloc_x(0:maxvar,2))
21154 !(maxvar,2)
21155       allocate(gel_loc(3,-1:nres))
21156       allocate(gel_loc_long(3,-1:nres))
21157       allocate(gcorr3_turn(3,-1:nres))
21158       allocate(gcorr4_turn(3,-1:nres))
21159       allocate(gcorr6_turn(3,-1:nres))
21160       allocate(gradb(3,-1:nres))
21161       allocate(gradbx(3,-1:nres))
21162 !(3,maxres)
21163       allocate(gel_loc_loc(maxvar))
21164       allocate(gel_loc_turn3(maxvar))
21165       allocate(gel_loc_turn4(maxvar))
21166       allocate(gel_loc_turn6(maxvar))
21167       allocate(gcorr_loc(maxvar))
21168       allocate(g_corr5_loc(maxvar))
21169       allocate(g_corr6_loc(maxvar))
21170 !(maxvar)
21171       allocate(gsccorc(3,-1:nres))
21172       allocate(gsccorx(3,-1:nres))
21173 !(3,maxres)
21174       allocate(gsccor_loc(-1:nres))
21175 !(maxres)
21176       allocate(gvdwx_scbase(3,-1:nres))
21177       allocate(gvdwc_scbase(3,-1:nres))
21178       allocate(gvdwx_pepbase(3,-1:nres))
21179       allocate(gvdwc_pepbase(3,-1:nres))
21180       allocate(gvdwx_scpho(3,-1:nres))
21181       allocate(gvdwc_scpho(3,-1:nres))
21182       allocate(gvdwc_peppho(3,-1:nres))
21183
21184       allocate(dtheta(3,2,-1:nres))
21185 !(3,2,maxres)
21186       allocate(gscloc(3,-1:nres))
21187       allocate(gsclocx(3,-1:nres))
21188 !(3,maxres)
21189       allocate(dphi(3,3,-1:nres))
21190       allocate(dalpha(3,3,-1:nres))
21191       allocate(domega(3,3,-1:nres))
21192 !(3,3,maxres)
21193 !      common /deriv_scloc/
21194       allocate(dXX_C1tab(3,nres))
21195       allocate(dYY_C1tab(3,nres))
21196       allocate(dZZ_C1tab(3,nres))
21197       allocate(dXX_Ctab(3,nres))
21198       allocate(dYY_Ctab(3,nres))
21199       allocate(dZZ_Ctab(3,nres))
21200       allocate(dXX_XYZtab(3,nres))
21201       allocate(dYY_XYZtab(3,nres))
21202       allocate(dZZ_XYZtab(3,nres))
21203 !(3,maxres)
21204 !      common /mpgrad/
21205       allocate(jgrad_start(nres))
21206       allocate(jgrad_end(nres))
21207 !(maxres)
21208 !----------------------
21209
21210 !      common /indices/
21211       allocate(ibond_displ(0:nfgtasks-1))
21212       allocate(ibond_count(0:nfgtasks-1))
21213       allocate(ithet_displ(0:nfgtasks-1))
21214       allocate(ithet_count(0:nfgtasks-1))
21215       allocate(iphi_displ(0:nfgtasks-1))
21216       allocate(iphi_count(0:nfgtasks-1))
21217       allocate(iphi1_displ(0:nfgtasks-1))
21218       allocate(iphi1_count(0:nfgtasks-1))
21219       allocate(ivec_displ(0:nfgtasks-1))
21220       allocate(ivec_count(0:nfgtasks-1))
21221       allocate(iset_displ(0:nfgtasks-1))
21222       allocate(iset_count(0:nfgtasks-1))
21223       allocate(iint_count(0:nfgtasks-1))
21224       allocate(iint_displ(0:nfgtasks-1))
21225 !(0:max_fg_procs-1)
21226 !----------------------
21227 ! common.MD
21228 !      common /mdgrad/
21229       allocate(gcart(3,-1:nres))
21230       allocate(gxcart(3,-1:nres))
21231 !(3,0:MAXRES)
21232       allocate(gradcag(3,-1:nres))
21233       allocate(gradxag(3,-1:nres))
21234 !(3,MAXRES)
21235 !      common /back_constr/
21236 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
21237       allocate(dutheta(nres))
21238       allocate(dugamma(nres))
21239 !(maxres)
21240       allocate(duscdiff(3,-1:nres))
21241       allocate(duscdiffx(3,-1:nres))
21242 !(3,maxres)
21243 !el i io:read_fragments
21244 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
21245 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
21246 !      common /qmeas/
21247 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
21248 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
21249       allocate(mset(0:nprocs))  !(maxprocs/20)
21250       mset(:)=0
21251 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
21252 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
21253       allocate(dUdconst(3,0:nres))
21254       allocate(dUdxconst(3,0:nres))
21255       allocate(dqwol(3,0:nres))
21256       allocate(dxqwol(3,0:nres))
21257 !(3,0:MAXRES)
21258 !----------------------
21259 ! common.sbridge
21260 !      common /sbridge/ in io_common: read_bridge
21261 !el    allocate((:),allocatable :: iss      !(maxss)
21262 !      common /links/  in io_common: read_bridge
21263 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
21264 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
21265 !      common /dyn_ssbond/
21266 ! and side-chain vectors in theta or phi.
21267       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
21268 !(maxres,maxres)
21269 !      do i=1,nres
21270 !        do j=i+1,nres
21271       dyn_ssbond_ij(:,:)=1.0d300
21272 !        enddo
21273 !      enddo
21274
21275 !      if (nss.gt.0) then
21276       allocate(idssb(maxdim),jdssb(maxdim))
21277 !        allocate(newihpb(nss),newjhpb(nss))
21278 !(maxdim)
21279 !      endif
21280       allocate(ishield_list(-1:nres))
21281       allocate(shield_list(maxcontsshi,-1:nres))
21282       allocate(dyn_ss_mask(nres))
21283       allocate(fac_shield(-1:nres))
21284       allocate(enetube(nres*2))
21285       allocate(enecavtube(nres*2))
21286
21287 !(maxres)
21288       dyn_ss_mask(:)=.false.
21289 !----------------------
21290 ! common.sccor
21291 ! Parameters of the SCCOR term
21292 !      common/sccor/
21293 !el in io_conf: parmread
21294 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
21295 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
21296 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
21297 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
21298 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
21299 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
21300 !      allocate(vlor1sccor(maxterm_sccor,20,20))
21301 !      allocate(vlor2sccor(maxterm_sccor,20,20))
21302 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
21303 !----------------
21304       allocate(gloc_sc(3,0:2*nres,0:10))
21305 !(3,0:maxres2,10)maxres2=2*maxres
21306       allocate(dcostau(3,3,3,2*nres))
21307       allocate(dsintau(3,3,3,2*nres))
21308       allocate(dtauangle(3,3,3,2*nres))
21309       allocate(dcosomicron(3,3,3,2*nres))
21310       allocate(domicron(3,3,3,2*nres))
21311 !(3,3,3,maxres2)maxres2=2*maxres
21312 !----------------------
21313 ! common.var
21314 !      common /restr/
21315       allocate(varall(maxvar))
21316 !(maxvar)(maxvar=6*maxres)
21317       allocate(mask_theta(nres))
21318       allocate(mask_phi(nres))
21319       allocate(mask_side(nres))
21320 !(maxres)
21321 !----------------------
21322 ! common.vectors
21323 !      common /vectors/
21324       allocate(uy(3,nres))
21325       allocate(uz(3,nres))
21326 !(3,maxres)
21327       allocate(uygrad(3,3,2,nres))
21328       allocate(uzgrad(3,3,2,nres))
21329 !(3,3,2,maxres)
21330 ! allocateion of lists JPRDLA
21331       allocate(newcontlistppi(300*nres))
21332       allocate(newcontlistscpi(350*nres))
21333       allocate(newcontlisti(300*nres))
21334       allocate(newcontlistppj(300*nres))
21335       allocate(newcontlistscpj(350*nres))
21336       allocate(newcontlistj(300*nres))
21337
21338       return
21339       end subroutine alloc_ener_arrays
21340 !-----------------------------------------------------------------
21341       subroutine ebond_nucl(estr_nucl)
21342 !c
21343 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
21344 !c
21345
21346       real(kind=8),dimension(3) :: u,ud
21347       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
21348       real(kind=8) :: estr_nucl,diff
21349       integer :: iti,i,j,k,nbi
21350       estr_nucl=0.0d0
21351 !C      print *,"I enter ebond"
21352       if (energy_dec) &
21353       write (iout,*) "ibondp_start,ibondp_end",&
21354        ibondp_nucl_start,ibondp_nucl_end
21355       do i=ibondp_nucl_start,ibondp_nucl_end
21356       if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
21357        itype(i,2).eq.ntyp1_molec(2)) cycle
21358 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
21359 !          do j=1,3
21360 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
21361 !     &      *dc(j,i-1)/vbld(i)
21362 !          enddo
21363 !          if (energy_dec) write(iout,*)
21364 !     &       "estr1",i,vbld(i),distchainmax,
21365 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
21366
21367         diff = vbld(i)-vbldp0_nucl
21368         if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
21369         vbldp0_nucl,diff,AKP_nucl*diff*diff
21370         estr_nucl=estr_nucl+diff*diff
21371 !          print *,estr_nucl
21372         do j=1,3
21373           gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
21374         enddo
21375 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
21376       enddo
21377       estr_nucl=0.5d0*AKP_nucl*estr_nucl
21378 !      print *,"partial sum", estr_nucl,AKP_nucl
21379
21380       if (energy_dec) &
21381       write (iout,*) "ibondp_start,ibondp_end",&
21382        ibond_nucl_start,ibond_nucl_end
21383
21384       do i=ibond_nucl_start,ibond_nucl_end
21385 !C        print *, "I am stuck",i
21386       iti=itype(i,2)
21387       if (iti.eq.ntyp1_molec(2)) cycle
21388         nbi=nbondterm_nucl(iti)
21389 !C        print *,iti,nbi
21390         if (nbi.eq.1) then
21391           diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
21392
21393           if (energy_dec) &
21394          write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
21395          AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
21396           estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
21397 !            print *,estr_nucl
21398           do j=1,3
21399             gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
21400           enddo
21401         else
21402           do j=1,nbi
21403             diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
21404             ud(j)=aksc_nucl(j,iti)*diff
21405             u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
21406           enddo
21407           uprod=u(1)
21408           do j=2,nbi
21409             uprod=uprod*u(j)
21410           enddo
21411           usum=0.0d0
21412           usumsqder=0.0d0
21413           do j=1,nbi
21414             uprod1=1.0d0
21415             uprod2=1.0d0
21416             do k=1,nbi
21417             if (k.ne.j) then
21418               uprod1=uprod1*u(k)
21419               uprod2=uprod2*u(k)*u(k)
21420             endif
21421             enddo
21422             usum=usum+uprod1
21423             usumsqder=usumsqder+ud(j)*uprod2
21424           enddo
21425           estr_nucl=estr_nucl+uprod/usum
21426           do j=1,3
21427            gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
21428           enddo
21429       endif
21430       enddo
21431 !C      print *,"I am about to leave ebond"
21432       return
21433       end subroutine ebond_nucl
21434
21435 !-----------------------------------------------------------------------------
21436       subroutine ebend_nucl(etheta_nucl)
21437       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
21438       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
21439       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
21440       logical :: lprn=.false., lprn1=.false.
21441 !el local variables
21442       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
21443       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
21444       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
21445 ! local variables for constrains
21446       real(kind=8) :: difi,thetiii
21447        integer itheta
21448       etheta_nucl=0.0D0
21449 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
21450       do i=ithet_nucl_start,ithet_nucl_end
21451       if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
21452       (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
21453       (itype(i,2).eq.ntyp1_molec(2))) cycle
21454       dethetai=0.0d0
21455       dephii=0.0d0
21456       dephii1=0.0d0
21457       theti2=0.5d0*theta(i)
21458       ityp2=ithetyp_nucl(itype(i-1,2))
21459       do k=1,nntheterm_nucl
21460         coskt(k)=dcos(k*theti2)
21461         sinkt(k)=dsin(k*theti2)
21462       enddo
21463       if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
21464 #ifdef OSF
21465         phii=phi(i)
21466         if (phii.ne.phii) phii=150.0
21467 #else
21468         phii=phi(i)
21469 #endif
21470         ityp1=ithetyp_nucl(itype(i-2,2))
21471         do k=1,nsingle_nucl
21472           cosph1(k)=dcos(k*phii)
21473           sinph1(k)=dsin(k*phii)
21474         enddo
21475       else
21476         phii=0.0d0
21477         ityp1=nthetyp_nucl+1
21478         do k=1,nsingle_nucl
21479           cosph1(k)=0.0d0
21480           sinph1(k)=0.0d0
21481         enddo
21482       endif
21483
21484       if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
21485 #ifdef OSF
21486         phii1=phi(i+1)
21487         if (phii1.ne.phii1) phii1=150.0
21488         phii1=pinorm(phii1)
21489 #else
21490         phii1=phi(i+1)
21491 #endif
21492         ityp3=ithetyp_nucl(itype(i,2))
21493         do k=1,nsingle_nucl
21494           cosph2(k)=dcos(k*phii1)
21495           sinph2(k)=dsin(k*phii1)
21496         enddo
21497       else
21498         phii1=0.0d0
21499         ityp3=nthetyp_nucl+1
21500         do k=1,nsingle_nucl
21501           cosph2(k)=0.0d0
21502           sinph2(k)=0.0d0
21503         enddo
21504       endif
21505       ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
21506       do k=1,ndouble_nucl
21507         do l=1,k-1
21508           ccl=cosph1(l)*cosph2(k-l)
21509           ssl=sinph1(l)*sinph2(k-l)
21510           scl=sinph1(l)*cosph2(k-l)
21511           csl=cosph1(l)*sinph2(k-l)
21512           cosph1ph2(l,k)=ccl-ssl
21513           cosph1ph2(k,l)=ccl+ssl
21514           sinph1ph2(l,k)=scl+csl
21515           sinph1ph2(k,l)=scl-csl
21516         enddo
21517       enddo
21518       if (lprn) then
21519       write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
21520        " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
21521       write (iout,*) "coskt and sinkt",nntheterm_nucl
21522       do k=1,nntheterm_nucl
21523         write (iout,*) k,coskt(k),sinkt(k)
21524       enddo
21525       endif
21526       do k=1,ntheterm_nucl
21527         ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
21528         dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
21529          *coskt(k)
21530         if (lprn)&
21531        write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
21532         " ethetai",ethetai
21533       enddo
21534       if (lprn) then
21535       write (iout,*) "cosph and sinph"
21536       do k=1,nsingle_nucl
21537         write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
21538       enddo
21539       write (iout,*) "cosph1ph2 and sinph2ph2"
21540       do k=2,ndouble_nucl
21541         do l=1,k-1
21542           write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
21543             sinph1ph2(l,k),sinph1ph2(k,l)
21544         enddo
21545       enddo
21546       write(iout,*) "ethetai",ethetai
21547       endif
21548       do m=1,ntheterm2_nucl
21549         do k=1,nsingle_nucl
21550           aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
21551             +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
21552             +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
21553             +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
21554           ethetai=ethetai+sinkt(m)*aux
21555           dethetai=dethetai+0.5d0*m*aux*coskt(m)
21556           dephii=dephii+k*sinkt(m)*(&
21557              ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
21558              bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
21559           dephii1=dephii1+k*sinkt(m)*(&
21560              eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
21561              ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
21562           if (lprn) &
21563          write (iout,*) "m",m," k",k," bbthet",&
21564             bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
21565             ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
21566             ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
21567             eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21568         enddo
21569       enddo
21570       if (lprn) &
21571       write(iout,*) "ethetai",ethetai
21572       do m=1,ntheterm3_nucl
21573         do k=2,ndouble_nucl
21574           do l=1,k-1
21575             aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21576              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
21577              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21578              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
21579             ethetai=ethetai+sinkt(m)*aux
21580             dethetai=dethetai+0.5d0*m*coskt(m)*aux
21581             dephii=dephii+l*sinkt(m)*(&
21582             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
21583              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21584              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
21585              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21586             dephii1=dephii1+(k-l)*sinkt(m)*( &
21587             -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
21588              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
21589              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
21590              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
21591             if (lprn) then
21592             write (iout,*) "m",m," k",k," l",l," ffthet", &
21593              ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
21594              ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
21595              ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
21596              ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
21597             write (iout,*) cosph1ph2(l,k)*sinkt(m), &
21598              cosph1ph2(k,l)*sinkt(m),&
21599              sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
21600             endif
21601           enddo
21602         enddo
21603       enddo
21604 10      continue
21605       if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
21606       i,theta(i)*rad2deg,phii*rad2deg, &
21607       phii1*rad2deg,ethetai
21608       etheta_nucl=etheta_nucl+ethetai
21609 !        print *,i,"partial sum",etheta_nucl
21610       if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
21611       if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
21612       gloc(nphi+i-2,icg)=wang_nucl*dethetai
21613       enddo
21614       return
21615       end subroutine ebend_nucl
21616 !----------------------------------------------------
21617       subroutine etor_nucl(etors_nucl)
21618 !      implicit real*8 (a-h,o-z)
21619 !      include 'DIMENSIONS'
21620 !      include 'COMMON.VAR'
21621 !      include 'COMMON.GEO'
21622 !      include 'COMMON.LOCAL'
21623 !      include 'COMMON.TORSION'
21624 !      include 'COMMON.INTERACT'
21625 !      include 'COMMON.DERIV'
21626 !      include 'COMMON.CHAIN'
21627 !      include 'COMMON.NAMES'
21628 !      include 'COMMON.IOUNITS'
21629 !      include 'COMMON.FFIELD'
21630 !      include 'COMMON.TORCNSTR'
21631 !      include 'COMMON.CONTROL'
21632       real(kind=8) :: etors_nucl,edihcnstr
21633       logical :: lprn
21634 !el local variables
21635       integer :: i,j,iblock,itori,itori1
21636       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
21637                vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
21638 ! Set lprn=.true. for debugging
21639       lprn=.false.
21640 !     lprn=.true.
21641       etors_nucl=0.0D0
21642 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
21643       do i=iphi_nucl_start,iphi_nucl_end
21644       if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
21645            .or. itype(i-3,2).eq.ntyp1_molec(2) &
21646            .or. itype(i,2).eq.ntyp1_molec(2)) cycle
21647       etors_ii=0.0D0
21648       itori=itortyp_nucl(itype(i-2,2))
21649       itori1=itortyp_nucl(itype(i-1,2))
21650       phii=phi(i)
21651 !         print *,i,itori,itori1
21652       gloci=0.0D0
21653 !C Regular cosine and sine terms
21654       do j=1,nterm_nucl(itori,itori1)
21655         v1ij=v1_nucl(j,itori,itori1)
21656         v2ij=v2_nucl(j,itori,itori1)
21657         cosphi=dcos(j*phii)
21658         sinphi=dsin(j*phii)
21659         etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
21660         if (energy_dec) etors_ii=etors_ii+&
21661                  v1ij*cosphi+v2ij*sinphi
21662         gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
21663       enddo
21664 !C Lorentz terms
21665 !C                         v1
21666 !C  E = SUM ----------------------------------- - v1
21667 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
21668 !C
21669       cosphi=dcos(0.5d0*phii)
21670       sinphi=dsin(0.5d0*phii)
21671       do j=1,nlor_nucl(itori,itori1)
21672         vl1ij=vlor1_nucl(j,itori,itori1)
21673         vl2ij=vlor2_nucl(j,itori,itori1)
21674         vl3ij=vlor3_nucl(j,itori,itori1)
21675         pom=vl2ij*cosphi+vl3ij*sinphi
21676         pom1=1.0d0/(pom*pom+1.0d0)
21677         etors_nucl=etors_nucl+vl1ij*pom1
21678         if (energy_dec) etors_ii=etors_ii+ &
21679                  vl1ij*pom1
21680         pom=-pom*pom1*pom1
21681         gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
21682       enddo
21683 !C Subtract the constant term
21684       etors_nucl=etors_nucl-v0_nucl(itori,itori1)
21685         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
21686             'etor',i,etors_ii-v0_nucl(itori,itori1)
21687       if (lprn) &
21688        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
21689        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
21690        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
21691       gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
21692 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
21693       enddo
21694       return
21695       end subroutine etor_nucl
21696 !------------------------------------------------------------
21697       subroutine epp_nucl_sub(evdw1,ees)
21698 !C
21699 !C This subroutine calculates the average interaction energy and its gradient
21700 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
21701 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
21702 !C The potential depends both on the distance of peptide-group centers and on
21703 !C the orientation of the CA-CA virtual bonds.
21704 !C
21705       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
21706       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbbi,sslipi,ssgradlipi, &
21707                       sslipj,ssgradlipj,faclipij2
21708       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
21709              dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
21710              dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
21711       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21712                 dist_temp, dist_init,sss_grad,fac,evdw1ij
21713       integer xshift,yshift,zshift
21714       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
21715       real(kind=8) :: ees,eesij
21716 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21717       real(kind=8) scal_el /0.5d0/
21718       t_eelecij=0.0d0
21719       ees=0.0D0
21720       evdw1=0.0D0
21721       ind=0
21722 !c
21723 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
21724 !c
21725 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
21726       do i=iatel_s_nucl,iatel_e_nucl
21727       if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21728       dxi=dc(1,i)
21729       dyi=dc(2,i)
21730       dzi=dc(3,i)
21731       dx_normi=dc_norm(1,i)
21732       dy_normi=dc_norm(2,i)
21733       dz_normi=dc_norm(3,i)
21734       xmedi=c(1,i)+0.5d0*dxi
21735       ymedi=c(2,i)+0.5d0*dyi
21736       zmedi=c(3,i)+0.5d0*dzi
21737         call to_box(xmedi,ymedi,zmedi)
21738         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
21739
21740       do j=ielstart_nucl(i),ielend_nucl(i)
21741         if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
21742         ind=ind+1
21743         dxj=dc(1,j)
21744         dyj=dc(2,j)
21745         dzj=dc(3,j)
21746 !          xj=c(1,j)+0.5D0*dxj-xmedi
21747 !          yj=c(2,j)+0.5D0*dyj-ymedi
21748 !          zj=c(3,j)+0.5D0*dzj-zmedi
21749         xj=c(1,j)+0.5D0*dxj
21750         yj=c(2,j)+0.5D0*dyj
21751         zj=c(3,j)+0.5D0*dzj
21752      call to_box(xj,yj,zj)
21753      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
21754       faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
21755       xj=boxshift(xj-xmedi,boxxsize)
21756       yj=boxshift(yj-ymedi,boxysize)
21757       zj=boxshift(zj-zmedi,boxzsize)
21758         rij=xj*xj+yj*yj+zj*zj
21759 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
21760         fac=(r0pp**2/rij)**3
21761         ev1=epspp*fac*fac
21762         ev2=epspp*fac
21763         evdw1ij=ev1-2*ev2
21764         fac=(-ev1-evdw1ij)/rij
21765 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
21766         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
21767         evdw1=evdw1+evdw1ij
21768 !C
21769 !C Calculate contributions to the Cartesian gradient.
21770 !C
21771         ggg(1)=fac*xj
21772         ggg(2)=fac*yj
21773         ggg(3)=fac*zj
21774         do k=1,3
21775           gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
21776           gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
21777         enddo
21778 !c phoshate-phosphate electrostatic interactions
21779         rij=dsqrt(rij)
21780         fac=1.0d0/rij
21781         eesij=dexp(-BEES*rij)*fac
21782 !          write (2,*)"fac",fac," eesijpp",eesij
21783         if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
21784         ees=ees+eesij
21785 !c          fac=-eesij*fac
21786         fac=-(fac+BEES)*eesij*fac
21787         ggg(1)=fac*xj
21788         ggg(2)=fac*yj
21789         ggg(3)=fac*zj
21790 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
21791 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
21792 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
21793         do k=1,3
21794           gelpp(k,i)=gelpp(k,i)-ggg(k)
21795           gelpp(k,j)=gelpp(k,j)+ggg(k)
21796         enddo
21797       enddo ! j
21798       enddo   ! i
21799 !c      ees=332.0d0*ees
21800       ees=AEES*ees
21801       do i=nnt,nct
21802 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21803       do k=1,3
21804         gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
21805 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
21806         gelpp(k,i)=AEES*gelpp(k,i)
21807       enddo
21808 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
21809       enddo
21810 !c      write (2,*) "total EES",ees
21811       return
21812       end subroutine epp_nucl_sub
21813 !---------------------------------------------------------------------
21814       subroutine epsb(evdwpsb,eelpsb)
21815 !      use comm_locel
21816 !C
21817 !C This subroutine calculates the excluded-volume interaction energy between
21818 !C peptide-group centers and side chains and its gradient in virtual-bond and
21819 !C side-chain vectors.
21820 !C
21821       real(kind=8),dimension(3):: ggg
21822       integer :: i,iint,j,k,iteli,itypj,subchap
21823       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
21824                e1,e2,evdwij,rij,evdwpsb,eelpsb
21825       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21826                 dist_temp, dist_init
21827       integer xshift,yshift,zshift
21828
21829 !cd    print '(a)','Enter ESCP'
21830 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
21831       eelpsb=0.0d0
21832       evdwpsb=0.0d0
21833 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
21834       do i=iatscp_s_nucl,iatscp_e_nucl
21835       if (itype(i,2).eq.ntyp1_molec(2) &
21836        .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
21837       xi=0.5D0*(c(1,i)+c(1,i+1))
21838       yi=0.5D0*(c(2,i)+c(2,i+1))
21839       zi=0.5D0*(c(3,i)+c(3,i+1))
21840         call to_box(xi,yi,zi)
21841
21842       do iint=1,nscp_gr_nucl(i)
21843
21844       do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
21845         itypj=itype(j,2)
21846         if (itypj.eq.ntyp1_molec(2)) cycle
21847 !C Uncomment following three lines for SC-p interactions
21848 !c         xj=c(1,nres+j)-xi
21849 !c         yj=c(2,nres+j)-yi
21850 !c         zj=c(3,nres+j)-zi
21851 !C Uncomment following three lines for Ca-p interactions
21852 !          xj=c(1,j)-xi
21853 !          yj=c(2,j)-yi
21854 !          zj=c(3,j)-zi
21855         xj=c(1,j)
21856         yj=c(2,j)
21857         zj=c(3,j)
21858         call to_box(xj,yj,zj)
21859       xj=boxshift(xj-xi,boxxsize)
21860       yj=boxshift(yj-yi,boxysize)
21861       zj=boxshift(zj-zi,boxzsize)
21862
21863       dist_init=xj**2+yj**2+zj**2
21864
21865         rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21866         fac=rrij**expon2
21867         e1=fac*fac*aad_nucl(itypj)
21868         e2=fac*bad_nucl(itypj)
21869         if (iabs(j-i) .le. 2) then
21870           e1=scal14*e1
21871           e2=scal14*e2
21872         endif
21873         evdwij=e1+e2
21874         evdwpsb=evdwpsb+evdwij
21875         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
21876            'evdw2',i,j,evdwij,"tu4"
21877 !C
21878 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
21879 !C
21880         fac=-(evdwij+e1)*rrij
21881         ggg(1)=xj*fac
21882         ggg(2)=yj*fac
21883         ggg(3)=zj*fac
21884         do k=1,3
21885           gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
21886           gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
21887         enddo
21888       enddo
21889
21890       enddo ! iint
21891       enddo ! i
21892       do i=1,nct
21893       do j=1,3
21894         gvdwpsb(j,i)=expon*gvdwpsb(j,i)
21895         gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
21896       enddo
21897       enddo
21898       return
21899       end subroutine epsb
21900
21901 !------------------------------------------------------
21902       subroutine esb_gb(evdwsb,eelsb)
21903       use comm_locel
21904       use calc_data_nucl
21905       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
21906       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
21907       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
21908       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21909                 dist_temp, dist_init,aa,bb,faclip,sig0ij
21910       integer :: ii
21911       logical lprn
21912       evdw=0.0D0
21913       eelsb=0.0d0
21914       ecorr=0.0d0
21915       evdwsb=0.0D0
21916       lprn=.false.
21917       ind=0
21918 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
21919       do i=iatsc_s_nucl,iatsc_e_nucl
21920       num_conti=0
21921       num_conti2=0
21922       itypi=itype(i,2)
21923 !        PRINT *,"I=",i,itypi
21924       if (itypi.eq.ntyp1_molec(2)) cycle
21925       itypi1=itype(i+1,2)
21926       xi=c(1,nres+i)
21927       yi=c(2,nres+i)
21928       zi=c(3,nres+i)
21929       call to_box(xi,yi,zi)
21930       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
21931       dxi=dc_norm(1,nres+i)
21932       dyi=dc_norm(2,nres+i)
21933       dzi=dc_norm(3,nres+i)
21934       dsci_inv=vbld_inv(i+nres)
21935 !C
21936 !C Calculate SC interaction energy.
21937 !C
21938       do iint=1,nint_gr_nucl(i)
21939 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
21940         do j=istart_nucl(i,iint),iend_nucl(i,iint)
21941           ind=ind+1
21942 !            print *,"JESTEM"
21943           itypj=itype(j,2)
21944           if (itypj.eq.ntyp1_molec(2)) cycle
21945           dscj_inv=vbld_inv(j+nres)
21946           sig0ij=sigma_nucl(itypi,itypj)
21947           chi1=chi_nucl(itypi,itypj)
21948           chi2=chi_nucl(itypj,itypi)
21949           chi12=chi1*chi2
21950           chip1=chip_nucl(itypi,itypj)
21951           chip2=chip_nucl(itypj,itypi)
21952           chip12=chip1*chip2
21953 !            xj=c(1,nres+j)-xi
21954 !            yj=c(2,nres+j)-yi
21955 !            zj=c(3,nres+j)-zi
21956          xj=c(1,nres+j)
21957          yj=c(2,nres+j)
21958          zj=c(3,nres+j)
21959      call to_box(xj,yj,zj)
21960 !     call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
21961 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
21962 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
21963 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
21964 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
21965       xj=boxshift(xj-xi,boxxsize)
21966       yj=boxshift(yj-yi,boxysize)
21967       zj=boxshift(zj-zi,boxzsize)
21968
21969           dxj=dc_norm(1,nres+j)
21970           dyj=dc_norm(2,nres+j)
21971           dzj=dc_norm(3,nres+j)
21972           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
21973           rij=dsqrt(rrij)
21974 !C Calculate angle-dependent terms of energy and contributions to their
21975 !C derivatives.
21976           erij(1)=xj*rij
21977           erij(2)=yj*rij
21978           erij(3)=zj*rij
21979           om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
21980           om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
21981           om12=dxi*dxj+dyi*dyj+dzi*dzj
21982           call sc_angular_nucl
21983           sigsq=1.0D0/sigsq
21984           sig=sig0ij*dsqrt(sigsq)
21985           rij_shift=1.0D0/rij-sig+sig0ij
21986 !            print *,rij_shift,"rij_shift"
21987 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
21988 !c     &       " rij_shift",rij_shift
21989           if (rij_shift.le.0.0D0) then
21990             evdw=1.0D20
21991             return
21992           endif
21993           sigder=-sig*sigsq
21994 !c---------------------------------------------------------------
21995           rij_shift=1.0D0/rij_shift
21996           fac=rij_shift**expon
21997           e1=fac*fac*aa_nucl(itypi,itypj)
21998           e2=fac*bb_nucl(itypi,itypj)
21999           evdwij=eps1*eps2rt*(e1+e2)
22000 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
22001 !c     &       " e1",e1," e2",e2," evdwij",evdwij
22002           eps2der=evdwij
22003           evdwij=evdwij*eps2rt
22004           evdwsb=evdwsb+evdwij
22005           if (lprn) then
22006           sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
22007           epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
22008           write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
22009            restyp(itypi,2),i,restyp(itypj,2),j, &
22010            epsi,sigm,chi1,chi2,chip1,chip2, &
22011            eps1,eps2rt**2,sig,sig0ij, &
22012            om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
22013           evdwij
22014           write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
22015           endif
22016
22017           if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
22018                        'evdw',i,j,evdwij,"tu3"
22019
22020
22021 !C Calculate gradient components.
22022           e1=e1*eps1*eps2rt**2
22023           fac=-expon*(e1+evdwij)*rij_shift
22024           sigder=fac*sigder
22025           fac=rij*fac
22026 !c            fac=0.0d0
22027 !C Calculate the radial part of the gradient
22028           gg(1)=xj*fac
22029           gg(2)=yj*fac
22030           gg(3)=zj*fac
22031 !C Calculate angular part of the gradient.
22032           call sc_grad_nucl
22033           call eelsbij(eelij,num_conti2)
22034           if (energy_dec .and. &
22035          (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
22036         write (istat,'(e14.5)') evdwij
22037           eelsb=eelsb+eelij
22038         enddo      ! j
22039       enddo        ! iint
22040       num_cont_hb(i)=num_conti2
22041       enddo          ! i
22042 !c      write (iout,*) "Number of loop steps in EGB:",ind
22043 !cccc      energy_dec=.false.
22044       return
22045       end subroutine esb_gb
22046 !-------------------------------------------------------------------------------
22047       subroutine eelsbij(eesij,num_conti2)
22048       use comm_locel
22049       use calc_data_nucl
22050       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
22051       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
22052       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22053                 dist_temp, dist_init,rlocshield,fracinbuf
22054       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
22055
22056 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
22057       real(kind=8) scal_el /0.5d0/
22058       integer :: iteli,itelj,kkk,kkll,m,isubchap
22059       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
22060       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
22061       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
22062               r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
22063               el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
22064               ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
22065               a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
22066               ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
22067               ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
22068               ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
22069       ind=ind+1
22070       itypi=itype(i,2)
22071       itypj=itype(j,2)
22072 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
22073       ael6i=ael6_nucl(itypi,itypj)
22074       ael3i=ael3_nucl(itypi,itypj)
22075       ael63i=ael63_nucl(itypi,itypj)
22076       ael32i=ael32_nucl(itypi,itypj)
22077 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
22078 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
22079       dxj=dc(1,j+nres)
22080       dyj=dc(2,j+nres)
22081       dzj=dc(3,j+nres)
22082       dx_normi=dc_norm(1,i+nres)
22083       dy_normi=dc_norm(2,i+nres)
22084       dz_normi=dc_norm(3,i+nres)
22085       dx_normj=dc_norm(1,j+nres)
22086       dy_normj=dc_norm(2,j+nres)
22087       dz_normj=dc_norm(3,j+nres)
22088 !c      xj=c(1,j)+0.5D0*dxj-xmedi
22089 !c      yj=c(2,j)+0.5D0*dyj-ymedi
22090 !c      zj=c(3,j)+0.5D0*dzj-zmedi
22091       if (ipot_nucl.ne.2) then
22092       cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
22093       cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
22094       cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
22095       else
22096       cosa=om12
22097       cosb=om1
22098       cosg=om2
22099       endif
22100       r3ij=rij*rrij
22101       r6ij=r3ij*r3ij
22102       fac=cosa-3.0D0*cosb*cosg
22103       facfac=fac*fac
22104       fac1=3.0d0*(cosb*cosb+cosg*cosg)
22105       fac3=ael6i*r6ij
22106       fac4=ael3i*r3ij
22107       fac5=ael63i*r6ij
22108       fac6=ael32i*r6ij
22109 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
22110 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
22111       el1=fac3*(4.0D0+facfac-fac1)
22112       el2=fac4*fac
22113       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
22114       el4=fac6*facfac
22115       eesij=el1+el2+el3+el4
22116 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
22117       ees0ij=4.0D0+facfac-fac1
22118
22119       if (energy_dec) then
22120         if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
22121         write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
22122          sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
22123          restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
22124          (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
22125         write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
22126       endif
22127
22128 !C
22129 !C Calculate contributions to the Cartesian gradient.
22130 !C
22131       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
22132       fac1=fac
22133 !c      erij(1)=xj*rmij
22134 !c      erij(2)=yj*rmij
22135 !c      erij(3)=zj*rmij
22136 !*
22137 !* Radial derivatives. First process both termini of the fragment (i,j)
22138 !*
22139       ggg(1)=facel*xj
22140       ggg(2)=facel*yj
22141       ggg(3)=facel*zj
22142       do k=1,3
22143       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
22144       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
22145       gelsbx(k,j)=gelsbx(k,j)+ggg(k)
22146       gelsbx(k,i)=gelsbx(k,i)-ggg(k)
22147       enddo
22148 !*
22149 !* Angular part
22150 !*
22151       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
22152       fac4=-3.0D0*fac4
22153       fac3=-6.0D0*fac3
22154       fac5= 6.0d0*fac5
22155       fac6=-6.0d0*fac6
22156       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
22157        fac6*fac1*cosg
22158       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
22159        fac6*fac1*cosb
22160       do k=1,3
22161       dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
22162       dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
22163       enddo
22164       do k=1,3
22165       ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
22166       enddo
22167       do k=1,3
22168       gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
22169            +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
22170            + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
22171       gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
22172            +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
22173            + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
22174       gelsbc(k,j)=gelsbc(k,j)+ggg(k)
22175       gelsbc(k,i)=gelsbc(k,i)-ggg(k)
22176       enddo
22177 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
22178        IF ( j.gt.i+1 .and.&
22179         num_conti.le.maxcont) THEN
22180 !C
22181 !C Calculate the contact function. The ith column of the array JCONT will
22182 !C contain the numbers of atoms that make contacts with the atom I (of numbers
22183 !C greater than I). The arrays FACONT and GACONT will contain the values of
22184 !C the contact function and its derivative.
22185       r0ij=2.20D0*sigma_nucl(itypi,itypj)
22186 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
22187       call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
22188 !c        write (2,*) "fcont",fcont
22189       if (fcont.gt.0.0D0) then
22190         num_conti=num_conti+1
22191         num_conti2=num_conti2+1
22192
22193         if (num_conti.gt.maxconts) then
22194           write (iout,*) 'WARNING - max. # of contacts exceeded;',&
22195                     ' will skip next contacts for this conf.',maxconts
22196         else
22197           jcont_hb(num_conti,i)=j
22198 !c            write (iout,*) "num_conti",num_conti,
22199 !c     &        " jcont_hb",jcont_hb(num_conti,i)
22200 !C Calculate contact energies
22201           cosa4=4.0D0*cosa
22202           wij=cosa-3.0D0*cosb*cosg
22203           cosbg1=cosb+cosg
22204           cosbg2=cosb-cosg
22205           fac3=dsqrt(-ael6i)*r3ij
22206 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
22207           ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
22208           if (ees0tmp.gt.0) then
22209             ees0pij=dsqrt(ees0tmp)
22210           else
22211             ees0pij=0
22212           endif
22213           ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
22214           if (ees0tmp.gt.0) then
22215             ees0mij=dsqrt(ees0tmp)
22216           else
22217             ees0mij=0
22218           endif
22219           ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
22220           ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
22221 !c            write (iout,*) "i",i," j",j,
22222 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
22223           ees0pij1=fac3/ees0pij
22224           ees0mij1=fac3/ees0mij
22225           fac3p=-3.0D0*fac3*rrij
22226           ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
22227           ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
22228           ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
22229           ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
22230           ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
22231           ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
22232           ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
22233           ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
22234           ecosap=ecosa1+ecosa2
22235           ecosbp=ecosb1+ecosb2
22236           ecosgp=ecosg1+ecosg2
22237           ecosam=ecosa1-ecosa2
22238           ecosbm=ecosb1-ecosb2
22239           ecosgm=ecosg1-ecosg2
22240 !C End diagnostics
22241           facont_hb(num_conti,i)=fcont
22242           fprimcont=fprimcont/rij
22243           do k=1,3
22244             gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
22245             gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
22246           enddo
22247           gggp(1)=gggp(1)+ees0pijp*xj
22248           gggp(2)=gggp(2)+ees0pijp*yj
22249           gggp(3)=gggp(3)+ees0pijp*zj
22250           gggm(1)=gggm(1)+ees0mijp*xj
22251           gggm(2)=gggm(2)+ees0mijp*yj
22252           gggm(3)=gggm(3)+ees0mijp*zj
22253 !C Derivatives due to the contact function
22254           gacont_hbr(1,num_conti,i)=fprimcont*xj
22255           gacont_hbr(2,num_conti,i)=fprimcont*yj
22256           gacont_hbr(3,num_conti,i)=fprimcont*zj
22257           do k=1,3
22258 !c
22259 !c Gradient of the correlation terms
22260 !c
22261             gacontp_hb1(k,num_conti,i)= &
22262            (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
22263           + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
22264             gacontp_hb2(k,num_conti,i)= &
22265            (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
22266           + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
22267             gacontp_hb3(k,num_conti,i)=gggp(k)
22268             gacontm_hb1(k,num_conti,i)= &
22269            (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
22270           + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
22271             gacontm_hb2(k,num_conti,i)= &
22272            (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
22273           + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
22274             gacontm_hb3(k,num_conti,i)=gggm(k)
22275           enddo
22276         endif
22277       endif
22278       ENDIF
22279       return
22280       end subroutine eelsbij
22281 !------------------------------------------------------------------
22282       subroutine sc_grad_nucl
22283       use comm_locel
22284       use calc_data_nucl
22285       real(kind=8),dimension(3) :: dcosom1,dcosom2
22286       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
22287       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
22288       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
22289       do k=1,3
22290       dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
22291       dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
22292       enddo
22293       do k=1,3
22294       gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
22295       enddo
22296       do k=1,3
22297       gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
22298              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
22299              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22300       gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
22301              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22302              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22303       enddo
22304 !C
22305 !C Calculate the components of the gradient in DC and X
22306 !C
22307       do l=1,3
22308       gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
22309       gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
22310       enddo
22311       return
22312       end subroutine sc_grad_nucl
22313 !-----------------------------------------------------------------------
22314       subroutine esb(esbloc)
22315 !C Calculate the local energy of a side chain and its derivatives in the
22316 !C corresponding virtual-bond valence angles THETA and the spherical angles
22317 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
22318 !C added by Urszula Kozlowska. 07/11/2007
22319 !C
22320       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
22321       real(kind=8),dimension(9):: x
22322      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
22323       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
22324       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
22325       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
22326        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
22327        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
22328        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
22329        integer::it,nlobit,i,j,k
22330 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
22331       delta=0.02d0*pi
22332       esbloc=0.0D0
22333       do i=loc_start_nucl,loc_end_nucl
22334       if (itype(i,2).eq.ntyp1_molec(2)) cycle
22335       costtab(i+1) =dcos(theta(i+1))
22336       sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
22337       cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
22338       sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
22339       cosfac2=0.5d0/(1.0d0+costtab(i+1))
22340       cosfac=dsqrt(cosfac2)
22341       sinfac2=0.5d0/(1.0d0-costtab(i+1))
22342       sinfac=dsqrt(sinfac2)
22343       it=itype(i,2)
22344       if (it.eq.10) goto 1
22345
22346 !c
22347 !C  Compute the axes of tghe local cartesian coordinates system; store in
22348 !c   x_prime, y_prime and z_prime
22349 !c
22350       do j=1,3
22351         x_prime(j) = 0.00
22352         y_prime(j) = 0.00
22353         z_prime(j) = 0.00
22354       enddo
22355 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
22356 !C     &   dc_norm(3,i+nres)
22357       do j = 1,3
22358         x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
22359         y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
22360       enddo
22361       do j = 1,3
22362         z_prime(j) = -uz(j,i-1)
22363 !           z_prime(j)=0.0
22364       enddo
22365
22366       xx=0.0d0
22367       yy=0.0d0
22368       zz=0.0d0
22369       do j = 1,3
22370         xx = xx + x_prime(j)*dc_norm(j,i+nres)
22371         yy = yy + y_prime(j)*dc_norm(j,i+nres)
22372         zz = zz + z_prime(j)*dc_norm(j,i+nres)
22373       enddo
22374
22375       xxtab(i)=xx
22376       yytab(i)=yy
22377       zztab(i)=zz
22378        it=itype(i,2)
22379       do j = 1,9
22380         x(j) = sc_parmin_nucl(j,it)
22381       enddo
22382 #ifdef CHECK_COORD
22383 !Cc diagnostics - remove later
22384       xx1 = dcos(alph(2))
22385       yy1 = dsin(alph(2))*dcos(omeg(2))
22386       zz1 = -dsin(alph(2))*dsin(omeg(2))
22387       write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
22388        alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
22389        xx1,yy1,zz1
22390 !C,"  --- ", xx_w,yy_w,zz_w
22391 !c end diagnostics
22392 #endif
22393       sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22394       esbloc = esbloc + sumene
22395       sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
22396 !        print *,"enecomp",sumene,sumene2
22397 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
22398 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
22399 #ifdef DEBUG
22400       write (2,*) "x",(x(k),k=1,9)
22401 !C
22402 !C This section to check the numerical derivatives of the energy of ith side
22403 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
22404 !C #define DEBUG in the code to turn it on.
22405 !C
22406       write (2,*) "sumene               =",sumene
22407       aincr=1.0d-7
22408       xxsave=xx
22409       xx=xx+aincr
22410       write (2,*) xx,yy,zz
22411       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22412       de_dxx_num=(sumenep-sumene)/aincr
22413       xx=xxsave
22414       write (2,*) "xx+ sumene from enesc=",sumenep,sumene
22415       yysave=yy
22416       yy=yy+aincr
22417       write (2,*) xx,yy,zz
22418       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22419       de_dyy_num=(sumenep-sumene)/aincr
22420       yy=yysave
22421       write (2,*) "yy+ sumene from enesc=",sumenep,sumene
22422       zzsave=zz
22423       zz=zz+aincr
22424       write (2,*) xx,yy,zz
22425       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22426       de_dzz_num=(sumenep-sumene)/aincr
22427       zz=zzsave
22428       write (2,*) "zz+ sumene from enesc=",sumenep,sumene
22429       costsave=cost2tab(i+1)
22430       sintsave=sint2tab(i+1)
22431       cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
22432       sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
22433       sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
22434       de_dt_num=(sumenep-sumene)/aincr
22435       write (2,*) " t+ sumene from enesc=",sumenep,sumene
22436       cost2tab(i+1)=costsave
22437       sint2tab(i+1)=sintsave
22438 !C End of diagnostics section.
22439 #endif
22440 !C
22441 !C Compute the gradient of esc
22442 !C
22443       de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
22444       de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
22445       de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
22446       de_dtt=0.0d0
22447 #ifdef DEBUG
22448       write (2,*) "x",(x(k),k=1,9)
22449       write (2,*) "xx",xx," yy",yy," zz",zz
22450       write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
22451         " de_zz   ",de_zz," de_tt   ",de_tt
22452       write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
22453         " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
22454 #endif
22455 !C
22456        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
22457        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
22458        cosfac2xx=cosfac2*xx
22459        sinfac2yy=sinfac2*yy
22460        do k = 1,3
22461        dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
22462          vbld_inv(i+1)
22463        dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
22464          vbld_inv(i)
22465        pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
22466        pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
22467 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
22468 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
22469 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
22470 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
22471        dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
22472        dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
22473        dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
22474        dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
22475        dZZ_Ci1(k)=0.0d0
22476        dZZ_Ci(k)=0.0d0
22477        do j=1,3
22478          dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
22479          dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
22480        enddo
22481
22482        dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
22483        dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
22484        dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
22485 !c
22486        dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
22487        dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
22488        enddo
22489
22490        do k=1,3
22491        dXX_Ctab(k,i)=dXX_Ci(k)
22492        dXX_C1tab(k,i)=dXX_Ci1(k)
22493        dYY_Ctab(k,i)=dYY_Ci(k)
22494        dYY_C1tab(k,i)=dYY_Ci1(k)
22495        dZZ_Ctab(k,i)=dZZ_Ci(k)
22496        dZZ_C1tab(k,i)=dZZ_Ci1(k)
22497        dXX_XYZtab(k,i)=dXX_XYZ(k)
22498        dYY_XYZtab(k,i)=dYY_XYZ(k)
22499        dZZ_XYZtab(k,i)=dZZ_XYZ(k)
22500        enddo
22501        do k = 1,3
22502 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
22503 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
22504 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
22505 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
22506 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
22507 !c     &    dt_dci(k)
22508 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
22509 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
22510        gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
22511        +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
22512        gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
22513        +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
22514        gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
22515        +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
22516 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
22517        enddo
22518 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
22519 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
22520
22521 !C to check gradient call subroutine check_grad
22522
22523     1 continue
22524       enddo
22525       return
22526       end subroutine esb
22527 !=-------------------------------------------------------
22528       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
22529 !      implicit none
22530       real(kind=8),dimension(9):: x(9)
22531        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
22532       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
22533       integer i
22534 !c      write (2,*) "enesc"
22535 !c      write (2,*) "x",(x(i),i=1,9)
22536 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
22537       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
22538       + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
22539       + x(9)*yy*zz
22540       enesc_nucl=sumene
22541       return
22542       end function enesc_nucl
22543 !-----------------------------------------------------------------------------
22544       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
22545 #ifdef MPI
22546       include 'mpif.h'
22547       integer,parameter :: max_cont=2000
22548       integer,parameter:: max_dim=2*(8*3+6)
22549       integer, parameter :: msglen1=max_cont*max_dim
22550       integer,parameter :: msglen2=2*msglen1
22551       integer source,CorrelType,CorrelID,Error
22552       real(kind=8) :: buffer(max_cont,max_dim)
22553       integer status(MPI_STATUS_SIZE)
22554       integer :: ierror,nbytes
22555 #endif
22556       real(kind=8),dimension(3):: gx(3),gx1(3)
22557       real(kind=8) :: time00
22558       logical lprn,ldone
22559       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
22560       real(kind=8) ecorr,ecorr3
22561       integer :: n_corr,n_corr1,mm,msglen
22562 !C Set lprn=.true. for debugging
22563       lprn=.false.
22564       n_corr=0
22565       n_corr1=0
22566 #ifdef MPI
22567       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
22568
22569       if (nfgtasks.le.1) goto 30
22570       if (lprn) then
22571       write (iout,'(a)') 'Contact function values:'
22572       do i=nnt,nct-1
22573         write (iout,'(2i3,50(1x,i2,f5.2))')  &
22574        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22575        j=1,num_cont_hb(i))
22576       enddo
22577       endif
22578 !C Caution! Following code assumes that electrostatic interactions concerning
22579 !C a given atom are split among at most two processors!
22580       CorrelType=477
22581       CorrelID=fg_rank+1
22582       ldone=.false.
22583       do i=1,max_cont
22584       do j=1,max_dim
22585         buffer(i,j)=0.0D0
22586       enddo
22587       enddo
22588       mm=mod(fg_rank,2)
22589 !c      write (*,*) 'MyRank',MyRank,' mm',mm
22590       if (mm) 20,20,10
22591    10 continue
22592 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
22593       if (fg_rank.gt.0) then
22594 !C Send correlation contributions to the preceding processor
22595       msglen=msglen1
22596       nn=num_cont_hb(iatel_s_nucl)
22597       call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
22598 !c        write (*,*) 'The BUFFER array:'
22599 !c        do i=1,nn
22600 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
22601 !c        enddo
22602       if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
22603         msglen=msglen2
22604         call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
22605 !C Clear the contacts of the atom passed to the neighboring processor
22606       nn=num_cont_hb(iatel_s_nucl+1)
22607 !c        do i=1,nn
22608 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
22609 !c        enddo
22610           num_cont_hb(iatel_s_nucl)=0
22611       endif
22612 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
22613 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
22614 !cd   & ' msglen=',msglen
22615 !c        write (*,*) 'Processor ',fg_rank,MyRank,
22616 !c     & ' is sending correlation contribution to processor',fg_rank-1,
22617 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22618       time00=MPI_Wtime()
22619       call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
22620        CorrelType,FG_COMM,IERROR)
22621       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22622 !cd      write (iout,*) 'Processor ',fg_rank,
22623 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
22624 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
22625 !c        write (*,*) 'Processor ',fg_rank,
22626 !c     & ' has sent correlation contribution to processor',fg_rank-1,
22627 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
22628 !c        msglen=msglen1
22629       endif ! (fg_rank.gt.0)
22630       if (ldone) goto 30
22631       ldone=.true.
22632    20 continue
22633 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
22634       if (fg_rank.lt.nfgtasks-1) then
22635 !C Receive correlation contributions from the next processor
22636       msglen=msglen1
22637       if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
22638 !cd      write (iout,*) 'Processor',fg_rank,
22639 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
22640 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
22641 !c        write (*,*) 'Processor',fg_rank,
22642 !c     &' is receiving correlation contribution from processor',fg_rank+1,
22643 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
22644       time00=MPI_Wtime()
22645       nbytes=-1
22646       do while (nbytes.le.0)
22647         call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22648         call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
22649       enddo
22650 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
22651       call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
22652        fg_rank+1,CorrelType,FG_COMM,status,IERROR)
22653       time_sendrecv=time_sendrecv+MPI_Wtime()-time00
22654 !c        write (*,*) 'Processor',fg_rank,
22655 !c     &' has received correlation contribution from processor',fg_rank+1,
22656 !c     & ' msglen=',msglen,' nbytes=',nbytes
22657 !c        write (*,*) 'The received BUFFER array:'
22658 !c        do i=1,max_cont
22659 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
22660 !c        enddo
22661       if (msglen.eq.msglen1) then
22662         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
22663       else if (msglen.eq.msglen2)  then
22664         call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
22665         call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
22666       else
22667         write (iout,*) &
22668       'ERROR!!!! message length changed while processing correlations.'
22669         write (*,*) &
22670       'ERROR!!!! message length changed while processing correlations.'
22671         call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
22672       endif ! msglen.eq.msglen1
22673       endif ! fg_rank.lt.nfgtasks-1
22674       if (ldone) goto 30
22675       ldone=.true.
22676       goto 10
22677    30 continue
22678 #endif
22679       if (lprn) then
22680       write (iout,'(a)') 'Contact function values:'
22681       do i=nnt_molec(2),nct_molec(2)-1
22682         write (iout,'(2i3,50(1x,i2,f5.2))') &
22683        i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
22684        j=1,num_cont_hb(i))
22685       enddo
22686       endif
22687       ecorr=0.0D0
22688       ecorr3=0.0d0
22689 !C Remove the loop below after debugging !!!
22690 !      do i=nnt_molec(2),nct_molec(2)
22691 !        do j=1,3
22692 !          gradcorr_nucl(j,i)=0.0D0
22693 !          gradxorr_nucl(j,i)=0.0D0
22694 !          gradcorr3_nucl(j,i)=0.0D0
22695 !          gradxorr3_nucl(j,i)=0.0D0
22696 !        enddo
22697 !      enddo
22698 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
22699 !C Calculate the local-electrostatic correlation terms
22700       do i=iatsc_s_nucl,iatsc_e_nucl
22701       i1=i+1
22702       num_conti=num_cont_hb(i)
22703       num_conti1=num_cont_hb(i+1)
22704 !        print *,i,num_conti,num_conti1
22705       do jj=1,num_conti
22706         j=jcont_hb(jj,i)
22707         do kk=1,num_conti1
22708           j1=jcont_hb(kk,i1)
22709 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
22710 !c     &         ' jj=',jj,' kk=',kk
22711           if (j1.eq.j+1 .or. j1.eq.j-1) then
22712 !C
22713 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
22714 !C The system gains extra energy.
22715 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
22716 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22717 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
22718 !C
22719             ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22720             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
22721              'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
22722             n_corr=n_corr+1
22723           else if (j1.eq.j) then
22724 !C
22725 !C Contacts I-J and I-(J+1) occur simultaneously.
22726 !C The system loses extra energy.
22727 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
22728 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
22729 !C Need to implement full formulas 32 from Liwo et al., 1998.
22730 !C
22731 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22732 !c     &         ' jj=',jj,' kk=',kk
22733             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
22734           endif
22735         enddo ! kk
22736         do kk=1,num_conti
22737           j1=jcont_hb(kk,i)
22738 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
22739 !c     &         ' jj=',jj,' kk=',kk
22740           if (j1.eq.j+1) then
22741 !C Contacts I-J and (I+1)-J occur simultaneously.
22742 !C The system loses extra energy.
22743             ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
22744           endif ! j1==j+1
22745         enddo ! kk
22746       enddo ! jj
22747       enddo ! i
22748       return
22749       end subroutine multibody_hb_nucl
22750 !-----------------------------------------------------------
22751       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22752 !      implicit real*8 (a-h,o-z)
22753 !      include 'DIMENSIONS'
22754 !      include 'COMMON.IOUNITS'
22755 !      include 'COMMON.DERIV'
22756 !      include 'COMMON.INTERACT'
22757 !      include 'COMMON.CONTACTS'
22758       real(kind=8),dimension(3) :: gx,gx1
22759       logical :: lprn
22760 !el local variables
22761       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22762       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22763                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22764                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22765                rlocshield
22766
22767       lprn=.false.
22768       eij=facont_hb(jj,i)
22769       ekl=facont_hb(kk,k)
22770       ees0pij=ees0p(jj,i)
22771       ees0pkl=ees0p(kk,k)
22772       ees0mij=ees0m(jj,i)
22773       ees0mkl=ees0m(kk,k)
22774       ekont=eij*ekl
22775       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22776 !      print *,"ehbcorr_nucl",ekont,ees
22777 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22778 !C Following 4 lines for diagnostics.
22779 !cd    ees0pkl=0.0D0
22780 !cd    ees0pij=1.0D0
22781 !cd    ees0mkl=0.0D0
22782 !cd    ees0mij=1.0D0
22783 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22784 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22785 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22786 !C Calculate the multi-body contribution to energy.
22787 !      ecorr_nucl=ecorr_nucl+ekont*ees
22788 !C Calculate multi-body contributions to the gradient.
22789       coeffpees0pij=coeffp*ees0pij
22790       coeffmees0mij=coeffm*ees0mij
22791       coeffpees0pkl=coeffp*ees0pkl
22792       coeffmees0mkl=coeffm*ees0mkl
22793       do ll=1,3
22794       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
22795        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22796        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22797       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
22798       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
22799       coeffmees0mkl*gacontm_hb2(ll,jj,i))
22800       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
22801       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
22802       coeffmees0mij*gacontm_hb1(ll,kk,k))
22803       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
22804       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22805       coeffmees0mij*gacontm_hb2(ll,kk,k))
22806       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22807         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22808         coeffmees0mkl*gacontm_hb3(ll,jj,i))
22809       gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
22810       gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
22811       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22812         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22813         coeffmees0mij*gacontm_hb3(ll,kk,k))
22814       gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
22815       gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
22816       gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
22817       gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
22818       gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
22819       gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
22820       enddo
22821       ehbcorr_nucl=ekont*ees
22822       return
22823       end function ehbcorr_nucl
22824 !-------------------------------------------------------------------------
22825
22826      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
22827 !      implicit real*8 (a-h,o-z)
22828 !      include 'DIMENSIONS'
22829 !      include 'COMMON.IOUNITS'
22830 !      include 'COMMON.DERIV'
22831 !      include 'COMMON.INTERACT'
22832 !      include 'COMMON.CONTACTS'
22833       real(kind=8),dimension(3) :: gx,gx1
22834       logical :: lprn
22835 !el local variables
22836       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
22837       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
22838                ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
22839                coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
22840                rlocshield
22841
22842       lprn=.false.
22843       eij=facont_hb(jj,i)
22844       ekl=facont_hb(kk,k)
22845       ees0pij=ees0p(jj,i)
22846       ees0pkl=ees0p(kk,k)
22847       ees0mij=ees0m(jj,i)
22848       ees0mkl=ees0m(kk,k)
22849       ekont=eij*ekl
22850       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
22851 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
22852 !C Following 4 lines for diagnostics.
22853 !cd    ees0pkl=0.0D0
22854 !cd    ees0pij=1.0D0
22855 !cd    ees0mkl=0.0D0
22856 !cd    ees0mij=1.0D0
22857 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
22858 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
22859 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
22860 !C Calculate the multi-body contribution to energy.
22861 !      ecorr=ecorr+ekont*ees
22862 !C Calculate multi-body contributions to the gradient.
22863       coeffpees0pij=coeffp*ees0pij
22864       coeffmees0mij=coeffm*ees0mij
22865       coeffpees0pkl=coeffp*ees0pkl
22866       coeffmees0mkl=coeffm*ees0mkl
22867       do ll=1,3
22868       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
22869        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
22870        coeffmees0mkl*gacontm_hb1(ll,jj,i))
22871       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
22872       -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
22873       coeffmees0mkl*gacontm_hb2(ll,jj,i))
22874       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
22875       -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
22876       coeffmees0mij*gacontm_hb1(ll,kk,k))
22877       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
22878       -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
22879       coeffmees0mij*gacontm_hb2(ll,kk,k))
22880       gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
22881         ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
22882         coeffmees0mkl*gacontm_hb3(ll,jj,i))
22883       gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
22884       gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
22885       gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
22886         ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
22887         coeffmees0mij*gacontm_hb3(ll,kk,k))
22888       gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
22889       gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
22890       gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
22891       gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
22892       gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
22893       gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
22894       enddo
22895       ehbcorr3_nucl=ekont*ees
22896       return
22897       end function ehbcorr3_nucl
22898 #ifdef MPI
22899       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
22900       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22901       real(kind=8):: buffer(dimen1,dimen2)
22902       num_kont=num_cont_hb(atom)
22903       do i=1,num_kont
22904       do k=1,8
22905         do j=1,3
22906           buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
22907         enddo ! j
22908       enddo ! k
22909       buffer(i,indx+25)=facont_hb(i,atom)
22910       buffer(i,indx+26)=ees0p(i,atom)
22911       buffer(i,indx+27)=ees0m(i,atom)
22912       buffer(i,indx+28)=d_cont(i,atom)
22913       buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
22914       enddo ! i
22915       buffer(1,indx+30)=dfloat(num_kont)
22916       return
22917       end subroutine pack_buffer
22918 !c------------------------------------------------------------------------------
22919       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
22920       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
22921       real(kind=8):: buffer(dimen1,dimen2)
22922 !      double precision zapas
22923 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
22924 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
22925 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
22926 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
22927       num_kont=buffer(1,indx+30)
22928       num_kont_old=num_cont_hb(atom)
22929       num_cont_hb(atom)=num_kont+num_kont_old
22930       do i=1,num_kont
22931       ii=i+num_kont_old
22932       do k=1,8
22933         do j=1,3
22934           zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
22935         enddo ! j
22936       enddo ! k
22937       facont_hb(ii,atom)=buffer(i,indx+25)
22938       ees0p(ii,atom)=buffer(i,indx+26)
22939       ees0m(ii,atom)=buffer(i,indx+27)
22940       d_cont(i,atom)=buffer(i,indx+28)
22941       jcont_hb(ii,atom)=buffer(i,indx+29)
22942       enddo ! i
22943       return
22944       end subroutine unpack_buffer
22945 !c------------------------------------------------------------------------------
22946 #endif
22947       subroutine ecatcat(ecationcation)
22948       integer :: i,j,itmp,xshift,yshift,zshift,subchap,k,itypi,itypj
22949       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22950       r7,r4,ecationcation,k0,rcal,aa,bb,sslipi,ssgradlipi,sslipj,ssgradlipj
22951       real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22952       dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
22953       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22954       gg,r
22955
22956       ecationcation=0.0d0
22957       if (nres_molec(5).eq.0) return
22958       rcat0=3.472
22959       epscalc=0.05
22960       r06 = rcat0**6
22961       r012 = r06**2
22962 !        k0 = 332.0*(2.0*2.0)/80.0
22963       itmp=0
22964
22965       do i=1,4
22966       itmp=itmp+nres_molec(i)
22967       enddo
22968 !        write(iout,*) "itmp",itmp
22969       do i=itmp+1,itmp+nres_molec(5)-1
22970
22971       xi=c(1,i)
22972       yi=c(2,i)
22973       zi=c(3,i)
22974 !        write (iout,*) i,"TUTUT",c(1,i)
22975         itypi=itype(i,5)
22976       call to_box(xi,yi,zi)
22977       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
22978         do j=i+1,itmp+nres_molec(5)
22979         itypj=itype(j,5)
22980 !          print *,i,j,itypi,itypj
22981         k0 = 332.0*(ichargecat(itypi)*ichargecat(itypj))/80.0
22982 !           print *,i,j,'catcat'
22983          xj=c(1,j)
22984          yj=c(2,j)
22985          zj=c(3,j)
22986       call to_box(xj,yj,zj)
22987 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
22988 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22989 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22990 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
22991 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
22992       xj=boxshift(xj-xi,boxxsize)
22993       yj=boxshift(yj-yi,boxysize)
22994       zj=boxshift(zj-zi,boxzsize)
22995        rcal =xj**2+yj**2+zj**2
22996       ract=sqrt(rcal)
22997 !        rcat0=3.472
22998 !        epscalc=0.05
22999 !        r06 = rcat0**6
23000 !        r012 = r06**2
23001 !        k0 = 332*(2*2)/80
23002       Evan1cat=epscalc*(r012/(rcal**6))
23003       Evan2cat=epscalc*2*(r06/(rcal**3))
23004       Eeleccat=k0/ract
23005       r7 = rcal**7
23006       r4 = rcal**4
23007       r(1)=xj
23008       r(2)=yj
23009       r(3)=zj
23010       do k=1,3
23011         dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
23012         dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
23013         dEeleccat(k)=-k0*r(k)/ract**3
23014       enddo
23015       do k=1,3
23016         gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
23017         gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
23018         gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
23019       enddo
23020       if (energy_dec) write (iout,*) i,j,Evan1cat,Evan2cat,Eeleccat,&
23021        r012,rcal**6,ichargecat(itypi)*ichargecat(itypj)
23022 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
23023       ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
23024        enddo
23025        enddo
23026        return
23027        end subroutine ecatcat
23028 !---------------------------------------------------------------------------
23029 ! new for K+
23030       subroutine ecats_prot_amber(evdw)
23031 !      subroutine ecat_prot2(ecation_prot)
23032       use calc_data
23033       use comm_momo
23034
23035       logical :: lprn
23036 !el local variables
23037       integer :: iint,itypi1,subchap,isel,itmp
23038       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
23039       real(kind=8) :: evdw,aa,bb
23040       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23041                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
23042                 sslipi,sslipj,faclip,alpha_sco
23043       integer :: ii
23044       real(kind=8) :: fracinbuf
23045       real (kind=8) :: escpho
23046       real (kind=8),dimension(4):: ener
23047       real(kind=8) :: b1,b2,egb
23048       real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
23049        Lambf,&
23050        Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
23051        ecations_prot_amber,dFdOM2,dFdL,dFdOM12,&
23052        federmaus,&
23053        d1i,d1j
23054 !       real(kind=8),dimension(3,2)::erhead_tail
23055 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
23056       real(kind=8) ::  facd4, adler, Fgb, facd3
23057       integer troll,jj,istate
23058       real (kind=8) :: dcosom1(3),dcosom2(3)
23059       real(kind=8) ::locbox(3)
23060       locbox(1)=boxxsize
23061           locbox(2)=boxysize
23062       locbox(3)=boxzsize
23063
23064       evdw=0.0D0
23065       if (nres_molec(5).eq.0) return
23066       eps_out=80.0d0
23067 !      sss_ele_cut=1.0d0
23068
23069       itmp=0
23070       do i=1,4
23071       itmp=itmp+nres_molec(i)
23072       enddo
23073 !        go to 17
23074 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
23075       do i=ibond_start,ibond_end
23076
23077 !        print *,"I am in EVDW",i
23078       itypi=iabs(itype(i,1))
23079
23080 !        if (i.ne.47) cycle
23081       if ((itypi.eq.ntyp1).or.(itypi.eq.10)) cycle
23082       itypi1=iabs(itype(i+1,1))
23083       xi=c(1,nres+i)
23084       yi=c(2,nres+i)
23085       zi=c(3,nres+i)
23086       call to_box(xi,yi,zi)
23087       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
23088       dxi=dc_norm(1,nres+i)
23089       dyi=dc_norm(2,nres+i)
23090       dzi=dc_norm(3,nres+i)
23091       dsci_inv=vbld_inv(i+nres)
23092        do j=itmp+1,itmp+nres_molec(5)
23093
23094 ! Calculate SC interaction energy.
23095           itypj=iabs(itype(j,5))
23096           if ((itypj.eq.ntyp1)) cycle
23097            CALL elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
23098
23099           dscj_inv=0.0
23100          xj=c(1,j)
23101          yj=c(2,j)
23102          zj=c(3,j)
23103
23104       call to_box(xj,yj,zj)
23105 !      write(iout,*) "xi,yi,zi,xj,yj,zj", xi,yi,zi,xj,yj,zj
23106
23107 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
23108 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23109 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23110 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
23111 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
23112       xj=boxshift(xj-xi,boxxsize)
23113       yj=boxshift(yj-yi,boxysize)
23114       zj=boxshift(zj-zi,boxzsize)
23115 !      write(iout,*) "xj,yj,zj", xj,yj,zj,boxxsize
23116
23117 !          dxj = dc_norm( 1, nres+j )
23118 !          dyj = dc_norm( 2, nres+j )
23119 !          dzj = dc_norm( 3, nres+j )
23120
23121         itypi = itype(i,1)
23122         itypj = itype(j,5)
23123 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
23124 ! sampling performed with amber package
23125 !          alf1   = 0.0d0
23126 !          alf2   = 0.0d0
23127 !          alf12  = 0.0d0
23128 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
23129         chi1 = chi1cat(itypi,itypj)
23130         chis1 = chis1cat(itypi,itypj)
23131         chip1 = chipp1cat(itypi,itypj)
23132 !          chi1=0.0d0
23133 !          chis1=0.0d0
23134 !          chip1=0.0d0
23135         chi2=0.0
23136         chip2=0.0
23137         chis2=0.0
23138 !          chis2 = chis(itypj,itypi)
23139         chis12 = chis1 * chis2
23140         sig1 = sigmap1cat(itypi,itypj)
23141 !          sig2 = sigmap2(itypi,itypj)
23142 ! alpha factors from Fcav/Gcav
23143         b1cav = alphasurcat(1,itypi,itypj)
23144         b2cav = alphasurcat(2,itypi,itypj)
23145         b3cav = alphasurcat(3,itypi,itypj)
23146         b4cav = alphasurcat(4,itypi,itypj)
23147
23148 !        b1cav=0.0d0
23149 !        b2cav=0.0d0
23150 !        b3cav=0.0d0
23151 !        b4cav=0.0d0
23152
23153 ! used to determine whether we want to do quadrupole calculations
23154        eps_in = epsintabcat(itypi,itypj)
23155        if (eps_in.eq.0.0) eps_in=1.0
23156
23157        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23158 !       Rtail = 0.0d0
23159
23160        DO k = 1, 3
23161       ctail(k,1)=c(k,i+nres)
23162       ctail(k,2)=c(k,j)
23163        END DO
23164       call to_box(ctail(1,1),ctail(2,1),ctail(3,1))
23165       call to_box(ctail(1,2),ctail(2,2),ctail(3,2))
23166 !c! tail distances will be themselves usefull elswhere
23167 !c1 (in Gcav, for example)
23168        do k=1,3
23169        Rtail_distance(k) = boxshift(ctail(k,2) - ctail(k,1),locbox(k))
23170        enddo
23171        Rtail = dsqrt( &
23172         (Rtail_distance(1)*Rtail_distance(1)) &
23173       + (Rtail_distance(2)*Rtail_distance(2)) &
23174       + (Rtail_distance(3)*Rtail_distance(3)))
23175 ! tail location and distance calculations
23176 ! dhead1
23177        d1 = dheadcat(1, 1, itypi, itypj)
23178 !       d2 = dhead(2, 1, itypi, itypj)
23179        DO k = 1,3
23180 ! location of polar head is computed by taking hydrophobic centre
23181 ! and moving by a d1 * dc_norm vector
23182 ! see unres publications for very informative images
23183       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
23184       chead(k,2) = c(k, j)
23185       enddo
23186       call to_box(chead(1,1),chead(2,1),chead(3,1))
23187       call to_box(chead(1,2),chead(2,2),chead(3,2))
23188 !      write(iout,*) "TEST",chead(1,1),chead(2,1),chead(3,1),dc_norm(k, i+nres),d1
23189 ! distance
23190 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23191 !         Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23192       do k=1,3
23193       Rhead_distance(k) = boxshift(chead(k,2) - chead(k,1),locbox(k))
23194        END DO
23195 ! pitagoras (root of sum of squares)
23196        Rhead = dsqrt( &
23197         (Rhead_distance(1)*Rhead_distance(1)) &
23198       + (Rhead_distance(2)*Rhead_distance(2)) &
23199       + (Rhead_distance(3)*Rhead_distance(3)))
23200 !-------------------------------------------------------------------
23201 ! zero everything that should be zero'ed
23202        evdwij = 0.0d0
23203        ECL = 0.0d0
23204        Elj = 0.0d0
23205        Equad = 0.0d0
23206        Epol = 0.0d0
23207        Fcav=0.0d0
23208        eheadtail = 0.0d0
23209        dGCLdOM1 = 0.0d0
23210        dGCLdOM2 = 0.0d0
23211        dGCLdOM12 = 0.0d0
23212        dPOLdOM1 = 0.0d0
23213        dPOLdOM2 = 0.0d0
23214         Fcav = 0.0d0
23215         Fisocav=0.0d0
23216         dFdR = 0.0d0
23217         dCAVdOM1  = 0.0d0
23218         dCAVdOM2  = 0.0d0
23219         dCAVdOM12 = 0.0d0
23220         dscj_inv = vbld_inv(j+nres)
23221 !          print *,i,j,dscj_inv,dsci_inv
23222 ! rij holds 1/(distance of Calpha atoms)
23223         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23224         rij  = dsqrt(rrij)
23225         CALL sc_angular
23226 ! this should be in elgrad_init but om's are calculated by sc_angular
23227 ! which in turn is used by older potentials
23228 ! om = omega, sqom = om^2
23229         sqom1  = om1 * om1
23230         sqom2  = om2 * om2
23231         sqom12 = om12 * om12
23232
23233 ! now we calculate EGB - Gey-Berne
23234 ! It will be summed up in evdwij and saved in evdw
23235         sigsq     = 1.0D0  / sigsq
23236         sig       = sig0ij * dsqrt(sigsq)
23237 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23238         rij_shift = Rtail - sig + sig0ij
23239         IF (rij_shift.le.0.0D0) THEN
23240          evdw = 1.0D20
23241       if (evdw.gt.1.0d6) then
23242       write (*,'(2(1x,a3,i3),7f7.2)') &
23243       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23244       1.0d0/rij,Rtail,Rhead,rij_shift, sig, sig0ij,sigsq
23245       write(*,*) facsig,faceps1_inv,om1,chiom1,chi1
23246      write(*,*) "ANISO?!",chi1
23247 !evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23248 !      Equad,evdwij+Fcav+eheadtail,evdw
23249       endif
23250
23251          RETURN
23252         END IF
23253         sigder = -sig * sigsq
23254         rij_shift = 1.0D0 / rij_shift
23255         fac       = rij_shift**expon
23256         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
23257 !          print *,"ADAM",aa_aq(itypi,itypj)
23258
23259 !          c1        = 0.0d0
23260         c2        = fac  * bb_aq_cat(itypi,itypj)
23261 !          c2        = 0.0d0
23262         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23263         eps2der   = eps3rt * evdwij
23264         eps3der   = eps2rt * evdwij
23265 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23266         evdwij    = eps2rt * eps3rt * evdwij
23267 !#ifdef TSCSC
23268 !          IF (bb_aq(itypi,itypj).gt.0) THEN
23269 !           evdw_p = evdw_p + evdwij
23270 !          ELSE
23271 !           evdw_m = evdw_m + evdwij
23272 !          END IF
23273 !#else
23274         evdw = evdw  &
23275             + evdwij
23276 !#endif
23277         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23278         fac    = -expon * (c1 + evdwij) * rij_shift
23279         sigder = fac * sigder
23280 ! Calculate distance derivative
23281         gg(1) =  fac
23282         gg(2) =  fac
23283         gg(3) =  fac
23284 !       print *,"GG(1),distance grad",gg(1)
23285         fac = chis1 * sqom1 + chis2 * sqom2 &
23286         - 2.0d0 * chis12 * om1 * om2 * om12
23287         pom = 1.0d0 - chis1 * chis2 * sqom12
23288         Lambf = (1.0d0 - (fac / pom))
23289         Lambf = dsqrt(Lambf)
23290         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23291         Chif = Rtail * sparrow
23292         ChiLambf = Chif * Lambf
23293         eagle = dsqrt(ChiLambf)
23294         bat = ChiLambf ** 11.0d0
23295         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
23296         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
23297         botsq = bot * bot
23298         Fcav = top / bot
23299
23300        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
23301        dbot = 12.0d0 * b4cav * bat * Lambf
23302        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23303
23304         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
23305         dbot = 12.0d0 * b4cav * bat * Chif
23306         eagle = Lambf * pom
23307         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23308         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23309         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23310             * (chis2 * om2 * om12 - om1) / (eagle * pom)
23311
23312         dFdL = ((dtop * bot - top * dbot) / botsq)
23313         dCAVdOM1  = dFdL * ( dFdOM1 )
23314         dCAVdOM2  = dFdL * ( dFdOM2 )
23315         dCAVdOM12 = dFdL * ( dFdOM12 )
23316
23317        DO k= 1, 3
23318       ertail(k) = Rtail_distance(k)/Rtail
23319        END DO
23320        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
23321        erdxj = scalar( ertail(1), dC_norm(1,j) )
23322        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
23323        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j)
23324        DO k = 1, 3
23325       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23326       gradpepcatx(k,i) = gradpepcatx(k,i) &
23327               - (( dFdR + gg(k) ) * pom)
23328       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j))
23329 !        gvdwx(k,j) = gvdwx(k,j)   &
23330 !                  + (( dFdR + gg(k) ) * pom)
23331       gradpepcat(k,i) = gradpepcat(k,i)  &
23332               - (( dFdR + gg(k) ) * ertail(k))
23333       gradpepcat(k,j) = gradpepcat(k,j) &
23334               + (( dFdR + gg(k) ) * ertail(k))
23335       gg(k) = 0.0d0
23336        ENDDO
23337 !c! Compute head-head and head-tail energies for each state
23338 !!        if (.false.) then ! turn off electrostatic
23339         if (itype(j,5).gt.0) then ! the normal cation case
23340         isel = iabs(Qi) + 1 ! ion is always charged so  iabs(Qj)
23341 !        print *,i,itype(i,1),isel
23342         IF (isel.eq.0) THEN
23343 !c! No charges - do nothing
23344          eheadtail = 0.0d0
23345
23346         ELSE IF (isel.eq.1) THEN
23347 !c! Nonpolar-charge interactions
23348         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23349           Qi=Qi*2
23350           Qij=Qij*2
23351          endif
23352
23353          CALL enq_cat(epol)
23354          eheadtail = epol
23355 !           eheadtail = 0.0d0
23356
23357         ELSE IF (isel.eq.3) THEN
23358 !c! Dipole-charge interactions
23359         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23360           Qi=Qi*2
23361           Qij=Qij*2
23362          endif
23363 !         write(iout,*) "KURWA0",d1
23364
23365          CALL edq_cat(ecl, elj, epol)
23366         eheadtail = ECL + elj + epol
23367 !           eheadtail = 0.0d0
23368
23369         ELSE IF ((isel.eq.2)) THEN
23370
23371 !c! Same charge-charge interaction ( +/+ or -/- )
23372         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23373           Qi=Qi*2
23374           Qij=Qij*2
23375          endif
23376
23377          CALL eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
23378          eheadtail = ECL + Egb + Epol + Fisocav + Elj
23379 !           eheadtail = 0.0d0
23380
23381 !          ELSE IF ((isel.eq.2.and.  &
23382 !               iabs(Qi).eq.1).and. &
23383 !               nstate(itypi,itypj).ne.1) THEN
23384 !c! Different charge-charge interaction ( +/- or -/+ )
23385 !          if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23386 !            Qi=Qi*2
23387 !            Qij=Qij*2
23388 !           endif
23389 !          if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
23390 !            Qj=Qj*2
23391 !            Qij=Qij*2
23392 !           endif
23393 !
23394 !           CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
23395        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
23396        else
23397        write(iout,*) "not yet implemented",j,itype(j,5)
23398        endif
23399 !!       endif ! turn off electrostatic
23400       evdw = evdw  + Fcav + eheadtail
23401 !      if (evdw.gt.1.0d6) then
23402 !      write (*,'(2(1x,a3,i3),3f6.2,10f16.7)') &
23403 !      restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23404 !      1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23405 !      Equad,evdwij+Fcav+eheadtail,evdw
23406 !      endif
23407
23408        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
23409       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23410       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23411       Equad,evdwij+Fcav+eheadtail,evdw
23412 !       evdw = evdw  + Fcav  + eheadtail
23413 !       print *,"before sc_grad_cat", i,j, gradpepcat(1,j)
23414 !        iF (nstate(itypi,itypj).eq.1) THEN
23415       CALL sc_grad_cat
23416 !       print *,"after sc_grad_cat", i,j, gradpepcat(1,j)
23417
23418 !       END IF
23419 !c!-------------------------------------------------------------------
23420 !c! NAPISY KONCOWE
23421        END DO   ! j
23422        END DO     ! i
23423 !c      write (iout,*) "Number of loop steps in EGB:",ind
23424 !c      energy_dec=.false.
23425 !              print *,"EVDW KURW",evdw,nres
23426 !!!        return
23427    17   continue
23428 !      go to 23
23429       do i=ibond_start,ibond_end
23430
23431 !        print *,"I am in EVDW",i
23432       itypi=10 ! the peptide group parameters are for glicine
23433
23434 !        if (i.ne.47) cycle
23435       if ((itype(i,1).eq.ntyp1).or.itype(i+1,1).eq.ntyp1) cycle
23436       itypi1=iabs(itype(i+1,1))
23437       xi=(c(1,i)+c(1,i+1))/2.0
23438       yi=(c(2,i)+c(2,i+1))/2.0
23439       zi=(c(3,i)+c(3,i+1))/2.0
23440         call to_box(xi,yi,zi)
23441       dxi=dc_norm(1,i)
23442       dyi=dc_norm(2,i)
23443       dzi=dc_norm(3,i)
23444       dsci_inv=vbld_inv(i+1)/2.0
23445        do j=itmp+1,itmp+nres_molec(5)
23446
23447 ! Calculate SC interaction energy.
23448           itypj=iabs(itype(j,5))
23449           if ((itypj.eq.ntyp1)) cycle
23450            CALL elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
23451
23452           dscj_inv=0.0
23453          xj=c(1,j)
23454          yj=c(2,j)
23455          zj=c(3,j)
23456         call to_box(xj,yj,zj)
23457       xj=boxshift(xj-xi,boxxsize)
23458       yj=boxshift(yj-yi,boxysize)
23459       zj=boxshift(zj-zi,boxzsize)
23460
23461         dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23462
23463         dxj = 0.0d0! dc_norm( 1, nres+j )
23464         dyj = 0.0d0!dc_norm( 2, nres+j )
23465         dzj = 0.0d0! dc_norm( 3, nres+j )
23466
23467         itypi = 10
23468         itypj = itype(j,5)
23469 ! Parameters from fitting the analitical expressions to the PMF obtained by umbrella
23470 ! sampling performed with amber package
23471 !          alf1   = 0.0d0
23472 !          alf2   = 0.0d0
23473 !          alf12  = 0.0d0
23474 !          a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
23475         chi1 = chi1cat(itypi,itypj)
23476         chis1 = chis1cat(itypi,itypj)
23477         chip1 = chipp1cat(itypi,itypj)
23478 !          chi1=0.0d0
23479 !          chis1=0.0d0
23480 !          chip1=0.0d0
23481         chi2=0.0
23482         chip2=0.0
23483         chis2=0.0
23484 !          chis2 = chis(itypj,itypi)
23485         chis12 = chis1 * chis2
23486         sig1 = sigmap1cat(itypi,itypj)
23487 !          sig2 = sigmap2(itypi,itypj)
23488 ! alpha factors from Fcav/Gcav
23489         b1cav = alphasurcat(1,itypi,itypj)
23490         b2cav = alphasurcat(2,itypi,itypj)
23491         b3cav = alphasurcat(3,itypi,itypj)
23492         b4cav = alphasurcat(4,itypi,itypj)
23493
23494 ! used to determine whether we want to do quadrupole calculations
23495        eps_in = epsintabcat(itypi,itypj)
23496        if (eps_in.eq.0.0) eps_in=1.0
23497
23498        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23499 !       Rtail = 0.0d0
23500
23501        DO k = 1, 3
23502       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0
23503       ctail(k,2)=c(k,j)
23504        END DO
23505       call to_box(ctail(1,1),ctail(2,1),ctail(3,1))
23506       call to_box(ctail(1,2),ctail(2,2),ctail(3,2))
23507 !c! tail distances will be themselves usefull elswhere
23508 !c1 (in Gcav, for example)
23509        do k=1,3
23510        Rtail_distance(k) = boxshift(ctail(k,2) - ctail(k,1),locbox(k))
23511        enddo
23512
23513 !c! tail distances will be themselves usefull elswhere
23514 !c1 (in Gcav, for example)
23515        Rtail = dsqrt( &
23516         (Rtail_distance(1)*Rtail_distance(1)) &
23517       + (Rtail_distance(2)*Rtail_distance(2)) &
23518       + (Rtail_distance(3)*Rtail_distance(3)))
23519 ! tail location and distance calculations
23520 ! dhead1
23521        d1 = dheadcat(1, 1, itypi, itypj)
23522 !       print *,"d1",d1
23523 !       d1=0.0d0
23524 !       d2 = dhead(2, 1, itypi, itypj)
23525        DO k = 1,3
23526 ! location of polar head is computed by taking hydrophobic centre
23527 ! and moving by a d1 * dc_norm vector
23528 ! see unres publications for very informative images
23529       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
23530       chead(k,2) = c(k, j)
23531        ENDDO
23532 ! distance
23533 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23534 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23535       call to_box(chead(1,1),chead(2,1),chead(3,1))
23536       call to_box(chead(1,2),chead(2,2),chead(3,2))
23537
23538 ! distance
23539 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23540 !         Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23541       do k=1,3
23542       Rhead_distance(k) = boxshift(chead(k,2) - chead(k,1),locbox(k))
23543        END DO
23544
23545 ! pitagoras (root of sum of squares)
23546        Rhead = dsqrt( &
23547         (Rhead_distance(1)*Rhead_distance(1)) &
23548       + (Rhead_distance(2)*Rhead_distance(2)) &
23549       + (Rhead_distance(3)*Rhead_distance(3)))
23550 !-------------------------------------------------------------------
23551 ! zero everything that should be zero'ed
23552        evdwij = 0.0d0
23553        ECL = 0.0d0
23554        Elj = 0.0d0
23555        Equad = 0.0d0
23556        Epol = 0.0d0
23557        Fcav=0.0d0
23558        eheadtail = 0.0d0
23559        dGCLdOM1 = 0.0d0
23560        dGCLdOM2 = 0.0d0
23561        dGCLdOM12 = 0.0d0
23562        dPOLdOM1 = 0.0d0
23563        dPOLdOM2 = 0.0d0
23564         Fcav = 0.0d0
23565         dFdR = 0.0d0
23566         dCAVdOM1  = 0.0d0
23567         dCAVdOM2  = 0.0d0
23568         dCAVdOM12 = 0.0d0
23569         dscj_inv = vbld_inv(j+nres)
23570 !          print *,i,j,dscj_inv,dsci_inv
23571 ! rij holds 1/(distance of Calpha atoms)
23572         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23573         rij  = dsqrt(rrij)
23574         CALL sc_angular
23575 ! this should be in elgrad_init but om's are calculated by sc_angular
23576 ! which in turn is used by older potentials
23577 ! om = omega, sqom = om^2
23578         sqom1  = om1 * om1
23579         sqom2  = om2 * om2
23580         sqom12 = om12 * om12
23581
23582 ! now we calculate EGB - Gey-Berne
23583 ! It will be summed up in evdwij and saved in evdw
23584         sigsq     = 1.0D0  / sigsq
23585         sig       = sig0ij * dsqrt(sigsq)
23586 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23587         rij_shift = Rtail - sig + sig0ij
23588         IF (rij_shift.le.0.0D0) THEN
23589          evdw = 1.0D20
23590 !      if (evdw.gt.1.0d6) then
23591 !      write (*,'(2(1x,a3,i3),6f6.2)') &
23592 !      restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23593 !      1.0d0/rij,Rtail,Rhead,rij_shift, sig, sig0ij
23594 !evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23595 !      Equad,evdwij+Fcav+eheadtail,evdw
23596 !      endif
23597          RETURN
23598         END IF
23599         sigder = -sig * sigsq
23600         rij_shift = 1.0D0 / rij_shift
23601         fac       = rij_shift**expon
23602         c1        = fac  * fac * aa_aq_cat(itypi,itypj)
23603 !          print *,"ADAM",aa_aq(itypi,itypj)
23604
23605 !          c1        = 0.0d0
23606         c2        = fac  * bb_aq_cat(itypi,itypj)
23607 !          c2        = 0.0d0
23608         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23609         eps2der   = eps3rt * evdwij
23610         eps3der   = eps2rt * evdwij
23611 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23612         evdwij    = eps2rt * eps3rt * evdwij
23613 !#ifdef TSCSC
23614 !          IF (bb_aq(itypi,itypj).gt.0) THEN
23615 !           evdw_p = evdw_p + evdwij
23616 !          ELSE
23617 !           evdw_m = evdw_m + evdwij
23618 !          END IF
23619 !#else
23620         evdw = evdw  &
23621             + evdwij
23622 !#endif
23623         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23624         fac    = -expon * (c1 + evdwij) * rij_shift
23625         sigder = fac * sigder
23626 ! Calculate distance derivative
23627         gg(1) =  fac
23628         gg(2) =  fac
23629         gg(3) =  fac
23630
23631         fac = chis1 * sqom1 + chis2 * sqom2 &
23632         - 2.0d0 * chis12 * om1 * om2 * om12
23633
23634         pom = 1.0d0 - chis1 * chis2 * sqom12
23635 !          print *,"TUT2",fac,chis1,sqom1,pom
23636         Lambf = (1.0d0 - (fac / pom))
23637         Lambf = dsqrt(Lambf)
23638         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23639         Chif = Rtail * sparrow
23640         ChiLambf = Chif * Lambf
23641         eagle = dsqrt(ChiLambf)
23642         bat = ChiLambf ** 11.0d0
23643         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
23644         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
23645         botsq = bot * bot
23646         Fcav = top / bot
23647
23648        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
23649        dbot = 12.0d0 * b4cav * bat * Lambf
23650        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23651
23652         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
23653         dbot = 12.0d0 * b4cav * bat * Chif
23654         eagle = Lambf * pom
23655         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23656         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23657         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23658             * (chis2 * om2 * om12 - om1) / (eagle * pom)
23659
23660         dFdL = ((dtop * bot - top * dbot) / botsq)
23661         dCAVdOM1  = dFdL * ( dFdOM1 )
23662         dCAVdOM2  = dFdL * ( dFdOM2 )
23663         dCAVdOM12 = dFdL * ( dFdOM12 )
23664
23665        DO k= 1, 3
23666       ertail(k) = Rtail_distance(k)/Rtail
23667        END DO
23668        erdxi = scalar( ertail(1), dC_norm(1,i) )
23669        erdxj = scalar( ertail(1), dC_norm(1,j) )
23670        facd1 = dtailcat(1,itypi,itypj) * vbld_inv(i)
23671        facd2 = dtailcat(2,itypi,itypj) * vbld_inv(j+nres)
23672        DO k = 1, 3
23673       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i))
23674 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
23675 !                  - (( dFdR + gg(k) ) * pom)
23676       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23677 !        gvdwx(k,j) = gvdwx(k,j)   &
23678 !                  + (( dFdR + gg(k) ) * pom)
23679       gradpepcat(k,i) = gradpepcat(k,i)  &
23680               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
23681       gradpepcat(k,i+1) = gradpepcat(k,i+1)  &
23682               - (( dFdR + gg(k) ) * ertail(k))/2.0d0
23683
23684       gradpepcat(k,j) = gradpepcat(k,j) &
23685               + (( dFdR + gg(k) ) * ertail(k))
23686       gg(k) = 0.0d0
23687        ENDDO
23688       if (itype(j,5).gt.0) then
23689 !c! Compute head-head and head-tail energies for each state
23690         isel = 3
23691 !c! Dipole-charge interactions
23692          CALL edq_cat_pep(ecl, elj, epol)
23693          eheadtail = ECL + elj + epol
23694 !          print *,"i,",i,eheadtail
23695 !           eheadtail = 0.0d0
23696       else
23697 !HERE WATER and other types of molecules solvents will be added
23698       write(iout,*) "not yet implemented"
23699 !      CALL edd_cat_pep
23700       endif
23701       evdw = evdw  + Fcav + eheadtail
23702 !      if (evdw.gt.1.0d6) then
23703 !      write (*,'(2(1x,a3,i3),3f6.2,10f16.7)') &
23704 !      restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23705 !      1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23706 !      Equad,evdwij+Fcav+eheadtail,evdw
23707 !      endif
23708        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
23709       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
23710       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
23711       Equad,evdwij+Fcav+eheadtail,evdw
23712 !       evdw = evdw  + Fcav  + eheadtail
23713
23714 !        iF (nstate(itypi,itypj).eq.1) THEN
23715       CALL sc_grad_cat_pep
23716 !       END IF
23717 !c!-------------------------------------------------------------------
23718 !c! NAPISY KONCOWE
23719        END DO   ! j
23720        END DO     ! i
23721 !c      write (iout,*) "Number of loop steps in EGB:",ind
23722 !c      energy_dec=.false.
23723 !              print *,"EVDW KURW",evdw,nres
23724  23   continue
23725 !       print *,"before leave sc_grad_cat", i,j, gradpepcat(1,nres-1)
23726
23727       return
23728       end subroutine ecats_prot_amber
23729
23730 !---------------------------------------------------------------------------
23731 ! old for Ca2+
23732        subroutine ecat_prot(ecation_prot)
23733 !      use calc_data
23734 !      use comm_momo
23735        integer i,j,k,subchap,itmp,inum
23736       real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
23737       r7,r4,ecationcation
23738       real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
23739       dist_init,dist_temp,ecation_prot,rcal,rocal,   &
23740       Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
23741       catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
23742       wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
23743       costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
23744       Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
23745       rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
23746       opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
23747       opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
23748       Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip,&
23749       ndiv,ndivi
23750       real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
23751       gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
23752       dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
23753       tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
23754       v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
23755       dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
23756       dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
23757       dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
23758       dEvan1Cat
23759       real(kind=8),dimension(6) :: vcatprm
23760       ecation_prot=0.0d0
23761 ! first lets calculate interaction with peptide groups
23762       if (nres_molec(5).eq.0) return
23763       itmp=0
23764       do i=1,4
23765       itmp=itmp+nres_molec(i)
23766       enddo
23767 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
23768       do i=ibond_start,ibond_end
23769 !         cycle
23770        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
23771       xi=0.5d0*(c(1,i)+c(1,i+1))
23772       yi=0.5d0*(c(2,i)+c(2,i+1))
23773       zi=0.5d0*(c(3,i)+c(3,i+1))
23774         call to_box(xi,yi,zi)
23775
23776        do j=itmp+1,itmp+nres_molec(5)
23777 !           print *,"WTF",itmp,j,i
23778 ! all parameters were for Ca2+ to approximate single charge divide by two
23779        ndiv=1.0
23780        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23781        wconst=78*ndiv
23782       wdip =1.092777950857032D2
23783       wdip=wdip/wconst
23784       wmodquad=-2.174122713004870D4
23785       wmodquad=wmodquad/wconst
23786       wquad1 = 3.901232068562804D1
23787       wquad1=wquad1/wconst
23788       wquad2 = 3
23789       wquad2=wquad2/wconst
23790       wvan1 = 0.1
23791       wvan2 = 6
23792 !        itmp=0
23793
23794          xj=c(1,j)
23795          yj=c(2,j)
23796          zj=c(3,j)
23797         call to_box(xj,yj,zj)
23798       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23799 !       enddo
23800 !       enddo
23801        rcpm = sqrt(xj**2+yj**2+zj**2)
23802        drcp_norm(1)=xj/rcpm
23803        drcp_norm(2)=yj/rcpm
23804        drcp_norm(3)=zj/rcpm
23805        dcmag=0.0
23806        do k=1,3
23807        dcmag=dcmag+dc(k,i)**2
23808        enddo
23809        dcmag=dsqrt(dcmag)
23810        do k=1,3
23811        myd_norm(k)=dc(k,i)/dcmag
23812        enddo
23813       costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
23814       drcp_norm(3)*myd_norm(3)
23815       rsecp = rcpm**2
23816       Ir = 1.0d0/rcpm
23817       Irsecp = 1.0d0/rsecp
23818       Irthrp = Irsecp/rcpm
23819       Irfourp = Irthrp/rcpm
23820       Irfiftp = Irfourp/rcpm
23821       Irsistp=Irfiftp/rcpm
23822       Irseven=Irsistp/rcpm
23823       Irtwelv=Irsistp*Irsistp
23824       Irthir=Irtwelv/rcpm
23825       sin2thet = (1-costhet*costhet)
23826       sinthet=sqrt(sin2thet)
23827       E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
23828            *sin2thet
23829       E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
23830            2*wvan2**6*Irsistp)
23831       ecation_prot = ecation_prot+E1+E2
23832 !        print *,"ecatprot",i,j,ecation_prot,rcpm
23833       dE1dr = -2*costhet*wdip*Irthrp-&
23834        (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
23835       dE2dr = 3*wquad1*wquad2*Irfourp-     &
23836         12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
23837       dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
23838       do k=1,3
23839         drdpep(k) = -drcp_norm(k)
23840         dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
23841         dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
23842         dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
23843         dEddci(k) = dEdcos*dcosddci(k)
23844       enddo
23845       do k=1,3
23846       gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
23847       gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
23848       gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
23849       enddo
23850        enddo ! j
23851        enddo ! i
23852 !------------------------------------------sidechains
23853 !        do i=1,nres_molec(1)
23854       do i=ibond_start,ibond_end
23855        if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
23856 !         cycle
23857 !        print *,i,ecation_prot
23858       xi=(c(1,i+nres))
23859       yi=(c(2,i+nres))
23860       zi=(c(3,i+nres))
23861                 call to_box(xi,yi,zi)
23862         do k=1,3
23863           cm1(k)=dc(k,i+nres)
23864         enddo
23865          cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
23866        do j=itmp+1,itmp+nres_molec(5)
23867        ndiv=1.0
23868        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23869
23870          xj=c(1,j)
23871          yj=c(2,j)
23872          zj=c(3,j)
23873         call to_box(xj,yj,zj)
23874       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23875 !       enddo
23876 !       enddo
23877 ! 15- Glu 16-Asp
23878        if((itype(i,1).eq.15.or.itype(i,1).eq.16).or.&
23879        ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.&
23880        (itype(i,1).eq.25))) then
23881           if(itype(i,1).eq.16) then
23882           inum=1
23883           else
23884           inum=2
23885           endif
23886           do k=1,6
23887           vcatprm(k)=catprm(k,inum)
23888           enddo
23889           dASGL=catprm(7,inum)
23890 !             do k=1,3
23891 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
23892             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
23893             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
23894             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
23895
23896 !                valpha(k)=c(k,i)
23897 !                vcat(k)=c(k,j)
23898             if (subchap.eq.1) then
23899              vcat(1)=xj_temp
23900              vcat(2)=yj_temp
23901              vcat(3)=zj_temp
23902              else
23903             vcat(1)=xj_safe
23904             vcat(2)=yj_safe
23905             vcat(3)=zj_safe
23906              endif
23907             valpha(1)=xi-c(1,i+nres)+c(1,i)
23908             valpha(2)=yi-c(2,i+nres)+c(2,i)
23909             valpha(3)=zi-c(3,i+nres)+c(3,i)
23910
23911 !              enddo
23912       do k=1,3
23913         dx(k) = vcat(k)-vcm(k)
23914       enddo
23915       do k=1,3
23916         v1(k)=(vcm(k)-valpha(k))
23917         v2(k)=(vcat(k)-valpha(k))
23918       enddo
23919       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
23920       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
23921       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
23922
23923 !  The weights of the energy function calculated from
23924 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
23925         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
23926           ndivi=0.5
23927         else
23928           ndivi=1.0
23929         endif
23930        ndiv=1.0
23931        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
23932
23933       wh2o=78*ndivi*ndiv
23934       wc = vcatprm(1)
23935       wc=wc/wh2o
23936       wdip =vcatprm(2)
23937       wdip=wdip/wh2o
23938       wquad1 =vcatprm(3)
23939       wquad1=wquad1/wh2o
23940       wquad2 = vcatprm(4)
23941       wquad2=wquad2/wh2o
23942       wquad2p = 1.0d0-wquad2
23943       wvan1 = vcatprm(5)
23944       wvan2 =vcatprm(6)
23945       opt = dx(1)**2+dx(2)**2
23946       rsecp = opt+dx(3)**2
23947       rs = sqrt(rsecp)
23948       rthrp = rsecp*rs
23949       rfourp = rthrp*rs
23950       rsixp = rfourp*rsecp
23951       reight=rsixp*rsecp
23952       Ir = 1.0d0/rs
23953       Irsecp = 1.0d0/rsecp
23954       Irthrp = Irsecp/rs
23955       Irfourp = Irthrp/rs
23956       Irsixp = 1.0d0/rsixp
23957       Ireight=1.0d0/reight
23958       Irtw=Irsixp*Irsixp
23959       Irthir=Irtw/rs
23960       Irfourt=Irthir/rs
23961       opt1 = (4*rs*dx(3)*wdip)
23962       opt2 = 6*rsecp*wquad1*opt
23963       opt3 = wquad1*wquad2p*Irsixp
23964       opt4 = (wvan1*wvan2**12)
23965       opt5 = opt4*12*Irfourt
23966       opt6 = 2*wvan1*wvan2**6
23967       opt7 = 6*opt6*Ireight
23968       opt8 = wdip/v1m
23969       opt10 = wdip/v2m
23970       opt11 = (rsecp*v2m)**2
23971       opt12 = (rsecp*v1m)**2
23972       opt14 = (v1m*v2m*rsecp)**2
23973       opt15 = -wquad1/v2m**2
23974       opt16 = (rthrp*(v1m*v2m)**2)**2
23975       opt17 = (v1m**2*rthrp)**2
23976       opt18 = -wquad1/rthrp
23977       opt19 = (v1m**2*v2m**2)**2
23978       Ec = wc*Ir
23979       do k=1,3
23980         dEcCat(k) = -(dx(k)*wc)*Irthrp
23981         dEcCm(k)=(dx(k)*wc)*Irthrp
23982         dEcCalp(k)=0.0d0
23983       enddo
23984       Edip=opt8*(v1dpv2)/(rsecp*v2m)
23985       do k=1,3
23986         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
23987                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
23988         dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
23989                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
23990         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
23991                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
23992                   *v1dpv2)/opt14
23993       enddo
23994       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
23995       do k=1,3
23996         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
23997                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
23998                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
23999         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
24000                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
24001                   v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
24002         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
24003                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
24004                   v1dpv2**2)/opt19
24005       enddo
24006       Equad2=wquad1*wquad2p*Irthrp
24007       do k=1,3
24008         dEquad2Cat(k)=-3*dx(k)*rs*opt3
24009         dEquad2Cm(k)=3*dx(k)*rs*opt3
24010         dEquad2Calp(k)=0.0d0
24011       enddo
24012       Evan1=opt4*Irtw
24013       do k=1,3
24014         dEvan1Cat(k)=-dx(k)*opt5
24015         dEvan1Cm(k)=dx(k)*opt5
24016         dEvan1Calp(k)=0.0d0
24017       enddo
24018       Evan2=-opt6*Irsixp
24019       do k=1,3
24020         dEvan2Cat(k)=dx(k)*opt7
24021         dEvan2Cm(k)=-dx(k)*opt7
24022         dEvan2Calp(k)=0.0d0
24023       enddo
24024       ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
24025 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
24026
24027       do k=1,3
24028         dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
24029                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
24030 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
24031         dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
24032                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
24033         dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
24034                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
24035       enddo
24036           dscmag = 0.0d0
24037           do k=1,3
24038             dscvec(k) = dc(k,i+nres)
24039             dscmag = dscmag+dscvec(k)*dscvec(k)
24040           enddo
24041           dscmag3 = dscmag
24042           dscmag = sqrt(dscmag)
24043           dscmag3 = dscmag3*dscmag
24044           constA = 1.0d0+dASGL/dscmag
24045           constB = 0.0d0
24046           do k=1,3
24047             constB = constB+dscvec(k)*dEtotalCm(k)
24048           enddo
24049           constB = constB*dASGL/dscmag3
24050           do k=1,3
24051             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
24052             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
24053              constA*dEtotalCm(k)-constB*dscvec(k)
24054 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
24055             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
24056             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
24057            enddo
24058       else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
24059          if(itype(i,1).eq.14) then
24060           inum=3
24061           else
24062           inum=4
24063           endif
24064           do k=1,6
24065           vcatprm(k)=catprm(k,inum)
24066           enddo
24067           dASGL=catprm(7,inum)
24068 !             do k=1,3
24069 !                vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
24070 !                valpha(k)=c(k,i)
24071 !                vcat(k)=c(k,j)
24072 !              enddo
24073             vcm(1)=(cm1(1)/cm1mag)*dASGL+xi
24074             vcm(2)=(cm1(2)/cm1mag)*dASGL+yi
24075             vcm(3)=(cm1(3)/cm1mag)*dASGL+zi
24076             if (subchap.eq.1) then
24077              vcat(1)=xj_temp
24078              vcat(2)=yj_temp
24079              vcat(3)=zj_temp
24080              else
24081             vcat(1)=xj_safe
24082             vcat(2)=yj_safe
24083             vcat(3)=zj_safe
24084             endif
24085             valpha(1)=xi-c(1,i+nres)+c(1,i)
24086             valpha(2)=yi-c(2,i+nres)+c(2,i)
24087             valpha(3)=zi-c(3,i+nres)+c(3,i)
24088
24089
24090       do k=1,3
24091         dx(k) = vcat(k)-vcm(k)
24092       enddo
24093       do k=1,3
24094         v1(k)=(vcm(k)-valpha(k))
24095         v2(k)=(vcat(k)-valpha(k))
24096       enddo
24097       v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
24098       v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
24099       v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
24100 !  The weights of the energy function calculated from
24101 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
24102        ndiv=1.0
24103        if ((itype(j,5).eq.1).or.(itype(j,5).eq.3)) ndiv=2.0
24104
24105       wh2o=78*ndiv
24106       wdip =vcatprm(2)
24107       wdip=wdip/wh2o
24108       wquad1 =vcatprm(3)
24109       wquad1=wquad1/wh2o
24110       wquad2 = vcatprm(4)
24111       wquad2=wquad2/wh2o
24112       wquad2p = 1-wquad2
24113       wvan1 = vcatprm(5)
24114       wvan2 =vcatprm(6)
24115       opt = dx(1)**2+dx(2)**2
24116       rsecp = opt+dx(3)**2
24117       rs = sqrt(rsecp)
24118       rthrp = rsecp*rs
24119       rfourp = rthrp*rs
24120       rsixp = rfourp*rsecp
24121       reight=rsixp*rsecp
24122       Ir = 1.0d0/rs
24123       Irsecp = 1/rsecp
24124       Irthrp = Irsecp/rs
24125       Irfourp = Irthrp/rs
24126       Irsixp = 1/rsixp
24127       Ireight=1/reight
24128       Irtw=Irsixp*Irsixp
24129       Irthir=Irtw/rs
24130       Irfourt=Irthir/rs
24131       opt1 = (4*rs*dx(3)*wdip)
24132       opt2 = 6*rsecp*wquad1*opt
24133       opt3 = wquad1*wquad2p*Irsixp
24134       opt4 = (wvan1*wvan2**12)
24135       opt5 = opt4*12*Irfourt
24136       opt6 = 2*wvan1*wvan2**6
24137       opt7 = 6*opt6*Ireight
24138       opt8 = wdip/v1m
24139       opt10 = wdip/v2m
24140       opt11 = (rsecp*v2m)**2
24141       opt12 = (rsecp*v1m)**2
24142       opt14 = (v1m*v2m*rsecp)**2
24143       opt15 = -wquad1/v2m**2
24144       opt16 = (rthrp*(v1m*v2m)**2)**2
24145       opt17 = (v1m**2*rthrp)**2
24146       opt18 = -wquad1/rthrp
24147       opt19 = (v1m**2*v2m**2)**2
24148       Edip=opt8*(v1dpv2)/(rsecp*v2m)
24149       do k=1,3
24150         dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
24151                  *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
24152        dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
24153                 *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
24154         dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
24155                   *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
24156                   *v1dpv2)/opt14
24157       enddo
24158       Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
24159       do k=1,3
24160         dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
24161                    (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
24162                    v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
24163         dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
24164                   (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
24165                    v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
24166         dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
24167                   v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
24168                   v1dpv2**2)/opt19
24169       enddo
24170       Equad2=wquad1*wquad2p*Irthrp
24171       do k=1,3
24172         dEquad2Cat(k)=-3*dx(k)*rs*opt3
24173         dEquad2Cm(k)=3*dx(k)*rs*opt3
24174         dEquad2Calp(k)=0.0d0
24175       enddo
24176       Evan1=opt4*Irtw
24177       do k=1,3
24178         dEvan1Cat(k)=-dx(k)*opt5
24179         dEvan1Cm(k)=dx(k)*opt5
24180         dEvan1Calp(k)=0.0d0
24181       enddo
24182       Evan2=-opt6*Irsixp
24183       do k=1,3
24184         dEvan2Cat(k)=dx(k)*opt7
24185         dEvan2Cm(k)=-dx(k)*opt7
24186         dEvan2Calp(k)=0.0d0
24187       enddo
24188        ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
24189       do k=1,3
24190         dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
24191                    dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
24192         dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
24193                   dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
24194         dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
24195                   +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
24196       enddo
24197           dscmag = 0.0d0
24198           do k=1,3
24199             dscvec(k) = c(k,i+nres)-c(k,i)
24200 ! TU SPRAWDZ???
24201 !              dscvec(1) = xj
24202 !              dscvec(2) = yj
24203 !              dscvec(3) = zj
24204
24205             dscmag = dscmag+dscvec(k)*dscvec(k)
24206           enddo
24207           dscmag3 = dscmag
24208           dscmag = sqrt(dscmag)
24209           dscmag3 = dscmag3*dscmag
24210           constA = 1+dASGL/dscmag
24211           constB = 0.0d0
24212           do k=1,3
24213             constB = constB+dscvec(k)*dEtotalCm(k)
24214           enddo
24215           constB = constB*dASGL/dscmag3
24216           do k=1,3
24217             gg(k) = dEtotalCm(k)+dEtotalCalp(k)
24218             gradpepcatx(k,i)=gradpepcatx(k,i)+ &
24219              constA*dEtotalCm(k)-constB*dscvec(k)
24220             gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
24221             gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
24222            enddo
24223          else
24224           rcal = 0.0d0
24225           do k=1,3
24226 !              r(k) = c(k,j)-c(k,i+nres)
24227             r(1) = xj
24228             r(2) = yj
24229             r(3) = zj
24230             rcal = rcal+r(k)*r(k)
24231           enddo
24232           ract=sqrt(rcal)
24233           rocal=1.5
24234           epscalc=0.2
24235           r0p=0.5*(rocal+sig0(itype(i,1)))
24236           r06 = r0p**6
24237           r012 = r06*r06
24238           Evan1=epscalc*(r012/rcal**6)
24239           Evan2=epscalc*2*(r06/rcal**3)
24240           r4 = rcal**4
24241           r7 = rcal**7
24242           do k=1,3
24243             dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
24244             dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
24245           enddo
24246           do k=1,3
24247             dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
24248           enddo
24249              ecation_prot = ecation_prot+ Evan1+Evan2
24250           do  k=1,3
24251              gradpepcatx(k,i)=gradpepcatx(k,i)+ &
24252              dEtotalCm(k)
24253             gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
24254             gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
24255            enddo
24256        endif ! 13-16 residues
24257        enddo !j
24258        enddo !i
24259        return
24260        end subroutine ecat_prot
24261
24262 !----------------------------------------------------------------------------
24263 !---------------------------------------------------------------------------
24264        subroutine ecat_nucl(ecation_nucl)
24265        integer i,j,k,subchap,itmp,inum,itypi,itypj
24266        real(kind=8) :: xi,yi,zi,xj,yj,zj
24267        real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
24268        dist_init,dist_temp,ecation_nucl,Evan1,Evan2,Ecav,Egb,wdip1,wdip2, &
24269        wvan1,wvan2,wgbsig,wgbeps,wgbchi,wgbchip,wcav1,wcav2,wcav3,wcav4, &
24270        wcavsig,wcavchi,v1m,v1dpdx,wh2o,wc,Edip,rcs2,invrcs6,invrcs8,invrcs12, &
24271        invrcs14,rcb,rcb2,invrcb,invrcb2,invrcb4,invrcb6,cosinus,cos2,dcosdcatconst, &
24272        dcosdcalpconst,dcosdcmconst,rcav,rcav11,rcav12,constcav1,constcav2, &
24273        constgb1,constgb2,constdvan1,constdvan2,sgb,sgb6,sgb7,sgb12,sgb13, &
24274        cavnum,cavdenom,invcavdenom2,dcavnumdcos,dcavnumdr,dcavdenomdcos, &
24275        dcavdenomdr,sslipi,ssgradlipi,sslipj,ssgradlipj,aa,bb
24276        real(kind=8),dimension(3) ::gg,r,dEtotalCm,dEtotalCalp,dEvan1Cm,&
24277        dEvan2Cm,cm1,cm,vcat,vsug,v1,v2,dx,vcm,dEdipCm,dEdipCalp, &
24278        dEvan1Calp,dEvan2Cat,dEvan2Calp,dEtotalCat,dEdipCat,dEvan1Cat,dcosdcat, &
24279        dcosdcalp,dcosdcm,dEgbdCat,dEgbdCalp,dEgbdCm,dEcavdCat,dEcavdCalp, &
24280        dEcavdCm,boxik
24281        real(kind=8),dimension(14) :: vcatnuclprm
24282        ecation_nucl=0.0d0
24283        boxik(1)=boxxsize
24284        boxik(2)=boxysize
24285        boxik(3)=boxzsize
24286
24287        if (nres_molec(5).eq.0) return
24288        itmp=0
24289        do i=1,4
24290           itmp=itmp+nres_molec(i)
24291        enddo
24292        do i=iatsc_s_nucl,iatsc_e_nucl
24293           if ((itype(i,2).eq.ntyp1_molec(2))) cycle ! leave dummy atoms
24294           xi=(c(1,i+nres))
24295           yi=(c(2,i+nres))
24296           zi=(c(3,i+nres))
24297       call to_box(xi,yi,zi)
24298       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
24299           do k=1,3
24300              cm1(k)=dc(k,i+nres)
24301           enddo
24302           do j=itmp+1,itmp+nres_molec(5)
24303              xj=c(1,j)
24304              yj=c(2,j)
24305              zj=c(3,j)
24306       call to_box(xj,yj,zj)
24307 !      write(iout,*) "xi,yi,zi,xj,yj,zj", xi,yi,zi,xj,yj,zj
24308 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
24309 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24310 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24311 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24312 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24313       xj=boxshift(xj-xi,boxxsize)
24314       yj=boxshift(yj-yi,boxysize)
24315       zj=boxshift(zj-zi,boxzsize)
24316 !       write(iout,*) 'after shift', xj,yj,zj
24317              dist_init=xj**2+yj**2+zj**2
24318
24319              itypi=itype(i,2)
24320              itypj=itype(j,5)
24321              do k=1,13
24322                 vcatnuclprm(k)=catnuclprm(k,itypi,itypj)
24323              enddo
24324              do k=1,3
24325                 vcm(k)=c(k,i+nres)
24326                 vsug(k)=c(k,i)
24327                 vcat(k)=c(k,j)
24328              enddo
24329              call to_box(vcm(1),vcm(2),vcm(3))
24330              call to_box(vsug(1),vsug(2),vsug(3))
24331              call to_box(vcat(1),vcat(2),vcat(3))
24332              do k=1,3
24333 !                dx(k) = vcat(k)-vcm(k)
24334 !             enddo
24335                 dx(k)=boxshift(vcat(k)-vcm(k),boxik(k))
24336 !             do k=1,3
24337                 v1(k)=dc(k,i+nres)
24338                 v2(k)=boxshift(vcat(k)-vsug(k),boxik(k))
24339              enddo
24340              v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
24341              v1dpdx = v1(1)*dx(1)+v1(2)*dx(2)+v1(3)*dx(3)
24342 !  The weights of the energy function calculated from
24343 !The quantum mechanical Gaussian simulations of potassium and sodium with deoxynucleosides
24344              wh2o=78
24345              wdip1 = vcatnuclprm(1)
24346              wdip1 = wdip1/wh2o                     !w1
24347              wdip2 = vcatnuclprm(2)
24348              wdip2 = wdip2/wh2o                     !w2
24349              wvan1 = vcatnuclprm(3)
24350              wvan2 = vcatnuclprm(4)                 !pis1
24351              wgbsig = vcatnuclprm(5)                !sigma0
24352              wgbeps = vcatnuclprm(6)                !epsi0
24353              wgbchi = vcatnuclprm(7)                !chi1
24354              wgbchip = vcatnuclprm(8)               !chip1
24355              wcavsig = vcatnuclprm(9)               !sig
24356              wcav1 = vcatnuclprm(10)                !b1
24357              wcav2 = vcatnuclprm(11)                !b2
24358              wcav3 = vcatnuclprm(12)                !b3
24359              wcav4 = vcatnuclprm(13)                !b4
24360              wcavchi = vcatnuclprm(14)              !chis1
24361              rcs2 = v2(1)**2+v2(2)**2+v2(3)**2
24362              invrcs6 = 1/rcs2**3
24363              invrcs8 = invrcs6/rcs2
24364              invrcs12 = invrcs6**2
24365              invrcs14 = invrcs12/rcs2
24366              rcb2 = dx(1)**2+dx(2)**2+dx(3)**2
24367              rcb = sqrt(rcb2)
24368              invrcb = 1/rcb
24369              invrcb2 = invrcb**2
24370              invrcb4 = invrcb2**2
24371              invrcb6 = invrcb4*invrcb2
24372              cosinus = v1dpdx/(v1m*rcb)
24373              cos2 = cosinus**2
24374              dcosdcatconst = invrcb2/v1m
24375              dcosdcalpconst = invrcb/v1m**2
24376              dcosdcmconst = invrcb2/v1m**2
24377              do k=1,3
24378                 dcosdcat(k) = (v1(k)*rcb-dx(k)*v1m*cosinus)*dcosdcatconst
24379                 dcosdcalp(k) = (v1(k)*rcb*cosinus-dx(k)*v1m)*dcosdcalpconst
24380                 dcosdcm(k) = ((dx(k)-v1(k))*v1m*rcb+ &
24381                         cosinus*(dx(k)*v1m**2-v1(k)*rcb2))*dcosdcmconst
24382              enddo
24383              rcav = rcb/wcavsig
24384              rcav11 = rcav**11
24385              rcav12 = rcav11*rcav
24386              constcav1 = 1-wcavchi*cos2
24387              constcav2 = sqrt(constcav1)
24388              constgb1 = 1/sqrt(1-wgbchi*cos2)
24389              constgb2 = wgbeps*(1-wgbchip*cos2)**2
24390              constdvan1 = 12*wvan1*wvan2**12*invrcs14
24391              constdvan2 = 6*wvan1*wvan2**6*invrcs8
24392 !----------------------------------------------------------------------------
24393 !Gay-Berne term
24394 !---------------------------------------------------------------------------
24395              sgb = 1/(1-constgb1+(rcb/wgbsig))
24396              sgb6 = sgb**6
24397              sgb7 = sgb6*sgb
24398              sgb12 = sgb6**2
24399              sgb13 = sgb12*sgb
24400              Egb = constgb2*(sgb12-sgb6)
24401              do k=1,3
24402                 dEgbdCat(k) = -constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) &
24403                  +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) &
24404      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcat(k)
24405                 dEgbdCm(k) = constgb2/wgbsig*(12*sgb13-6*sgb7)*invrcb*dx(k) &
24406                  +(constgb1**3*constgb2*wgbchi*cosinus*(12*sgb13-6*sgb7) &
24407      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcm(k)
24408                 dEgbdCalp(k) = (constgb1**3*constgb2*wgbchi*cosinus &
24409                                *(12*sgb13-6*sgb7) &
24410      -4*wgbeps*wgbchip*cosinus*(1-wgbchip*cos2)*(sgb12-sgb6))*dcosdcalp(k)
24411              enddo
24412 !----------------------------------------------------------------------------
24413 !cavity term
24414 !---------------------------------------------------------------------------
24415              cavnum = sqrt(rcav*constcav2)+wcav2*rcav*constcav2-wcav3
24416              cavdenom = 1+wcav4*rcav12*constcav1**6
24417              Ecav = wcav1*cavnum/cavdenom
24418              invcavdenom2 = 1/cavdenom**2
24419              dcavnumdcos = -wcavchi*cosinus/constcav2 &
24420                     *(sqrt(rcav/constcav2)/2+wcav2*rcav)
24421              dcavnumdr = (0.5*sqrt(constcav2/rcav)+wcav2*constcav2)/wcavsig
24422              dcavdenomdcos = -12*wcav4*wcavchi*rcav12*constcav1**5*cosinus
24423              dcavdenomdr = 12*wcav4/wcavsig*rcav11*constcav1**6
24424              do k=1,3
24425                 dEcavdCat(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
24426      *dcosdcat(k)+(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2
24427                 dEcavdCm(k) = ((dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
24428      *dcosdcm(k)-(dcavnumdr*cavdenom-dcavdenomdr*cavnum)/rcb*dx(k))*wcav1*invcavdenom2
24429                 dEcavdCalp(k) = (dcavnumdcos*cavdenom-dcavdenomdcos*cavnum) &
24430                              *dcosdcalp(k)*wcav1*invcavdenom2
24431              enddo
24432 !----------------------------------------------------------------------------
24433 !van der Waals and dipole-charge interaction energy
24434 !---------------------------------------------------------------------------
24435              Evan1 = wvan1*wvan2**12*invrcs12
24436              do k=1,3
24437                 dEvan1Cat(k) = -v2(k)*constdvan1
24438                 dEvan1Cm(k) = 0.0d0
24439                 dEvan1Calp(k) = v2(k)*constdvan1
24440              enddo
24441              Evan2 = -wvan1*wvan2**6*invrcs6
24442              do k=1,3
24443                 dEvan2Cat(k) = v2(k)*constdvan2
24444                 dEvan2Cm(k) = 0.0d0
24445                 dEvan2Calp(k) = -v2(k)*constdvan2
24446              enddo
24447              Edip = wdip1*cosinus*invrcb2-wdip2*(1-cos2)*invrcb4
24448              do k=1,3
24449                 dEdipCat(k) = (-2*wdip1*cosinus*invrcb4 &
24450                                +4*wdip2*(1-cos2)*invrcb6)*dx(k) &
24451                    +dcosdcat(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4)
24452                 dEdipCm(k) = (2*wdip1*cosinus*invrcb4 &
24453                              -4*wdip2*(1-cos2)*invrcb6)*dx(k) &
24454                    +dcosdcm(k)*(wdip1*invrcb2+2*wdip2*cosinus*invrcb4)
24455                 dEdipCalp(k) = dcosdcalp(k)*(wdip1*invrcb2 &
24456                                   +2*wdip2*cosinus*invrcb4)
24457              enddo
24458              if (energy_dec) write (iout,'(2i5,4(a6,f7.3))') i,j, &
24459          ' E GB ',Egb,' ECav ',Ecav,' Evdw ',Evan1+Evan2,' Edip ',Edip
24460              ecation_nucl=ecation_nucl+Ecav+Egb+Edip+Evan1+Evan2
24461              do k=1,3
24462                 dEtotalCat(k) = dEcavdCat(k)+dEvan1Cat(k)+dEvan2Cat(k) &
24463                                              +dEgbdCat(k)+dEdipCat(k)
24464                 dEtotalCm(k) = dEcavdCm(k)+dEvan1Cm(k)+dEvan2Cm(k) &
24465                                            +dEgbdCm(k)+dEdipCm(k)
24466                 dEtotalCalp(k) = dEcavdCalp(k)+dEgbdCalp(k)+dEvan1Calp(k) &
24467                                              +dEdipCalp(k)+dEvan2Calp(k)
24468              enddo
24469              do k=1,3
24470                 gg(k) = dEtotalCm(k)+dEtotalCalp(k)
24471                 gradnuclcatx(k,i)=gradnuclcatx(k,i)+dEtotalCm(k)
24472                 gradnuclcat(k,i)=gradnuclcat(k,i)+gg(k)
24473                 gradnuclcat(k,j)=gradnuclcat(k,j)+dEtotalCat(k)
24474              enddo
24475           enddo !j
24476        enddo !i
24477        return
24478        end subroutine ecat_nucl
24479
24480 !-----------------------------------------------------------------------------
24481 !-----------------------------------------------------------------------------
24482       subroutine eprot_sc_base(escbase)
24483       use calc_data
24484 !      implicit real*8 (a-h,o-z)
24485 !      include 'DIMENSIONS'
24486 !      include 'COMMON.GEO'
24487 !      include 'COMMON.VAR'
24488 !      include 'COMMON.LOCAL'
24489 !      include 'COMMON.CHAIN'
24490 !      include 'COMMON.DERIV'
24491 !      include 'COMMON.NAMES'
24492 !      include 'COMMON.INTERACT'
24493 !      include 'COMMON.IOUNITS'
24494 !      include 'COMMON.CALC'
24495 !      include 'COMMON.CONTROL'
24496 !      include 'COMMON.SBRIDGE'
24497       logical :: lprn
24498 !el local variables
24499       integer :: iint,itypi,itypi1,itypj,subchap
24500       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24501       real(kind=8) :: evdw,sig0ij
24502       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24503                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24504                 sslipi,sslipj,faclip
24505       integer :: ii
24506       real(kind=8) :: fracinbuf
24507        real (kind=8) :: escbase
24508        real (kind=8),dimension(4):: ener
24509        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24510        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24511       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
24512       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24513       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
24514       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24515       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24516       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
24517        real(kind=8),dimension(3,2)::chead,erhead_tail
24518        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24519        integer troll
24520        eps_out=80.0d0
24521        escbase=0.0d0
24522 !       do i=1,nres_molec(1)
24523       do i=ibond_start,ibond_end
24524       if (itype(i,1).eq.ntyp1_molec(1)) cycle
24525       itypi  = itype(i,1)
24526       dxi    = dc_norm(1,nres+i)
24527       dyi    = dc_norm(2,nres+i)
24528       dzi    = dc_norm(3,nres+i)
24529       dsci_inv = vbld_inv(i+nres)
24530       xi=c(1,nres+i)
24531       yi=c(2,nres+i)
24532       zi=c(3,nres+i)
24533       call to_box(xi,yi,zi)
24534       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
24535        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
24536          itypj= itype(j,2)
24537          if (itype(j,2).eq.ntyp1_molec(2))cycle
24538          xj=c(1,j+nres)
24539          yj=c(2,j+nres)
24540          zj=c(3,j+nres)
24541       call to_box(xj,yj,zj)
24542 !      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
24543 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24544 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24545 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
24546 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
24547       xj=boxshift(xj-xi,boxxsize)
24548       yj=boxshift(yj-yi,boxysize)
24549       zj=boxshift(zj-zi,boxzsize)
24550
24551         dxj = dc_norm( 1, nres+j )
24552         dyj = dc_norm( 2, nres+j )
24553         dzj = dc_norm( 3, nres+j )
24554 !          print *,i,j,itypi,itypj
24555         d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
24556         d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
24557 !          d1i=0.0d0
24558 !          d1j=0.0d0
24559 !          BetaT = 1.0d0 / (298.0d0 * Rb)
24560 ! Gay-berne var's
24561         sig0ij = sigma_scbase( itypi,itypj )
24562         chi1   = chi_scbase( itypi, itypj,1 )
24563         chi2   = chi_scbase( itypi, itypj,2 )
24564 !          chi1=0.0d0
24565 !          chi2=0.0d0
24566         chi12  = chi1 * chi2
24567         chip1  = chipp_scbase( itypi, itypj,1 )
24568         chip2  = chipp_scbase( itypi, itypj,2 )
24569 !          chip1=0.0d0
24570 !          chip2=0.0d0
24571         chip12 = chip1 * chip2
24572 ! not used by momo potential, but needed by sc_angular which is shared
24573 ! by all energy_potential subroutines
24574         alf1   = 0.0d0
24575         alf2   = 0.0d0
24576         alf12  = 0.0d0
24577         a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
24578 !       a12sq = a12sq * a12sq
24579 ! charge of amino acid itypi is...
24580         chis1 = chis_scbase(itypi,itypj,1)
24581         chis2 = chis_scbase(itypi,itypj,2)
24582         chis12 = chis1 * chis2
24583         sig1 = sigmap1_scbase(itypi,itypj)
24584         sig2 = sigmap2_scbase(itypi,itypj)
24585 !       write (*,*) "sig1 = ", sig1
24586 !       write (*,*) "sig2 = ", sig2
24587 ! alpha factors from Fcav/Gcav
24588         b1 = alphasur_scbase(1,itypi,itypj)
24589 !          b1=0.0d0
24590         b2 = alphasur_scbase(2,itypi,itypj)
24591         b3 = alphasur_scbase(3,itypi,itypj)
24592         b4 = alphasur_scbase(4,itypi,itypj)
24593 ! used to determine whether we want to do quadrupole calculations
24594 ! used by Fgb
24595        eps_in = epsintab_scbase(itypi,itypj)
24596        if (eps_in.eq.0.0) eps_in=1.0
24597        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24598 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24599 !-------------------------------------------------------------------
24600 ! tail location and distance calculations
24601        DO k = 1,3
24602 ! location of polar head is computed by taking hydrophobic centre
24603 ! and moving by a d1 * dc_norm vector
24604 ! see unres publications for very informative images
24605       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
24606       chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
24607 ! distance
24608 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24609 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24610       Rhead_distance(k) = chead(k,2) - chead(k,1)
24611        END DO
24612 ! pitagoras (root of sum of squares)
24613        Rhead = dsqrt( &
24614         (Rhead_distance(1)*Rhead_distance(1)) &
24615       + (Rhead_distance(2)*Rhead_distance(2)) &
24616       + (Rhead_distance(3)*Rhead_distance(3)))
24617 !-------------------------------------------------------------------
24618 ! zero everything that should be zero'ed
24619        evdwij = 0.0d0
24620        ECL = 0.0d0
24621        Elj = 0.0d0
24622        Equad = 0.0d0
24623        Epol = 0.0d0
24624        Fcav=0.0d0
24625        eheadtail = 0.0d0
24626        dGCLdOM1 = 0.0d0
24627        dGCLdOM2 = 0.0d0
24628        dGCLdOM12 = 0.0d0
24629        dPOLdOM1 = 0.0d0
24630        dPOLdOM2 = 0.0d0
24631         Fcav = 0.0d0
24632         dFdR = 0.0d0
24633         dCAVdOM1  = 0.0d0
24634         dCAVdOM2  = 0.0d0
24635         dCAVdOM12 = 0.0d0
24636         dscj_inv = vbld_inv(j+nres)
24637 !          print *,i,j,dscj_inv,dsci_inv
24638 ! rij holds 1/(distance of Calpha atoms)
24639         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24640         rij  = dsqrt(rrij)
24641 !----------------------------
24642         CALL sc_angular
24643 ! this should be in elgrad_init but om's are calculated by sc_angular
24644 ! which in turn is used by older potentials
24645 ! om = omega, sqom = om^2
24646         sqom1  = om1 * om1
24647         sqom2  = om2 * om2
24648         sqom12 = om12 * om12
24649
24650 ! now we calculate EGB - Gey-Berne
24651 ! It will be summed up in evdwij and saved in evdw
24652         sigsq     = 1.0D0  / sigsq
24653         sig       = sig0ij * dsqrt(sigsq)
24654 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24655         rij_shift = 1.0/rij - sig + sig0ij
24656         IF (rij_shift.le.0.0D0) THEN
24657          evdw = 1.0D20
24658          RETURN
24659         END IF
24660         sigder = -sig * sigsq
24661         rij_shift = 1.0D0 / rij_shift
24662         fac       = rij_shift**expon
24663         c1        = fac  * fac * aa_scbase(itypi,itypj)
24664 !          c1        = 0.0d0
24665         c2        = fac  * bb_scbase(itypi,itypj)
24666 !          c2        = 0.0d0
24667         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24668         eps2der   = eps3rt * evdwij
24669         eps3der   = eps2rt * evdwij
24670 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24671         evdwij    = eps2rt * eps3rt * evdwij
24672         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24673         fac    = -expon * (c1 + evdwij) * rij_shift
24674         sigder = fac * sigder
24675 !          fac    = rij * fac
24676 ! Calculate distance derivative
24677         gg(1) =  fac
24678         gg(2) =  fac
24679         gg(3) =  fac
24680 !          if (b2.gt.0.0) then
24681         fac = chis1 * sqom1 + chis2 * sqom2 &
24682         - 2.0d0 * chis12 * om1 * om2 * om12
24683 ! we will use pom later in Gcav, so dont mess with it!
24684         pom = 1.0d0 - chis1 * chis2 * sqom12
24685         Lambf = (1.0d0 - (fac / pom))
24686         Lambf = dsqrt(Lambf)
24687         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24688 !       write (*,*) "sparrow = ", sparrow
24689         Chif = 1.0d0/rij * sparrow
24690         ChiLambf = Chif * Lambf
24691         eagle = dsqrt(ChiLambf)
24692         bat = ChiLambf ** 11.0d0
24693         top = b1 * ( eagle + b2 * ChiLambf - b3 )
24694         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
24695         botsq = bot * bot
24696         Fcav = top / bot
24697 !          print *,i,j,Fcav
24698         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
24699         dbot = 12.0d0 * b4 * bat * Lambf
24700         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24701 !       dFdR = 0.0d0
24702 !      write (*,*) "dFcav/dR = ", dFdR
24703         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
24704         dbot = 12.0d0 * b4 * bat * Chif
24705         eagle = Lambf * pom
24706         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24707         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24708         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24709             * (chis2 * om2 * om12 - om1) / (eagle * pom)
24710
24711         dFdL = ((dtop * bot - top * dbot) / botsq)
24712 !       dFdL = 0.0d0
24713         dCAVdOM1  = dFdL * ( dFdOM1 )
24714         dCAVdOM2  = dFdL * ( dFdOM2 )
24715         dCAVdOM12 = dFdL * ( dFdOM12 )
24716
24717         ertail(1) = xj*rij
24718         ertail(2) = yj*rij
24719         ertail(3) = zj*rij
24720 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
24721 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
24722 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
24723 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
24724 !           print *,"EOMY",eom1,eom2,eom12
24725 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
24726 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
24727 ! here dtail=0.0
24728 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
24729 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24730        DO k = 1, 3
24731 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24732 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24733       pom = ertail(k)
24734 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24735       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
24736               - (( dFdR + gg(k) ) * pom)
24737 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24738 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24739 !     &             - ( dFdR * pom )
24740       pom = ertail(k)
24741 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24742       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
24743               + (( dFdR + gg(k) ) * pom)
24744 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24745 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24746 !c!     &             + ( dFdR * pom )
24747
24748       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
24749               - (( dFdR + gg(k) ) * ertail(k))
24750 !c!     &             - ( dFdR * ertail(k))
24751
24752       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
24753               + (( dFdR + gg(k) ) * ertail(k))
24754 !c!     &             + ( dFdR * ertail(k))
24755
24756       gg(k) = 0.0d0
24757 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24758 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24759       END DO
24760
24761 !          else
24762
24763 !          endif
24764 !Now dipole-dipole
24765        if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
24766        w1 = wdipdip_scbase(1,itypi,itypj)
24767        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
24768        w3 = wdipdip_scbase(2,itypi,itypj)
24769 !c!-------------------------------------------------------------------
24770 !c! ECL
24771        fac = (om12 - 3.0d0 * om1 * om2)
24772        c1 = (w1 / (Rhead**3.0d0)) * fac
24773        c2 = (w2 / Rhead ** 6.0d0)  &
24774        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24775        c3= (w3/ Rhead ** 6.0d0)  &
24776        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24777        ECL = c1 - c2 + c3
24778 !c!       write (*,*) "w1 = ", w1
24779 !c!       write (*,*) "w2 = ", w2
24780 !c!       write (*,*) "om1 = ", om1
24781 !c!       write (*,*) "om2 = ", om2
24782 !c!       write (*,*) "om12 = ", om12
24783 !c!       write (*,*) "fac = ", fac
24784 !c!       write (*,*) "c1 = ", c1
24785 !c!       write (*,*) "c2 = ", c2
24786 !c!       write (*,*) "Ecl = ", Ecl
24787 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
24788 !c!       write (*,*) "c2_2 = ",
24789 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
24790 !c!-------------------------------------------------------------------
24791 !c! dervative of ECL is GCL...
24792 !c! dECL/dr
24793        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
24794        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
24795        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
24796        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
24797        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
24798        dGCLdR = c1 - c2 + c3
24799 !c! dECL/dom1
24800        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
24801        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24802        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
24803        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
24804        dGCLdOM1 = c1 - c2 + c3
24805 !c! dECL/dom2
24806        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
24807        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
24808        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
24809        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
24810        dGCLdOM2 = c1 - c2 + c3
24811 !c! dECL/dom12
24812        c1 = w1 / (Rhead ** 3.0d0)
24813        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
24814        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
24815        dGCLdOM12 = c1 - c2 + c3
24816        DO k= 1, 3
24817       erhead(k) = Rhead_distance(k)/Rhead
24818        END DO
24819        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24820        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24821        facd1 = d1i * vbld_inv(i+nres)
24822        facd2 = d1j * vbld_inv(j+nres)
24823        DO k = 1, 3
24824
24825       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24826       gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
24827               - dGCLdR * pom
24828       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24829       gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
24830               + dGCLdR * pom
24831
24832       gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
24833               - dGCLdR * erhead(k)
24834       gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
24835               + dGCLdR * erhead(k)
24836        END DO
24837        endif
24838 !now charge with dipole eg. ARG-dG
24839        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
24840       alphapol1 = alphapol_scbase(itypi,itypj)
24841        w1        = wqdip_scbase(1,itypi,itypj)
24842        w2        = wqdip_scbase(2,itypi,itypj)
24843 !       w1=0.0d0
24844 !       w2=0.0d0
24845 !       pis       = sig0head_scbase(itypi,itypj)
24846 !       eps_head   = epshead_scbase(itypi,itypj)
24847 !c!-------------------------------------------------------------------
24848 !c! R1 - distance between head of ith side chain and tail of jth sidechain
24849        R1 = 0.0d0
24850        DO k = 1, 3
24851 !c! Calculate head-to-tail distances tail is center of side-chain
24852       R1=R1+(c(k,j+nres)-chead(k,1))**2
24853        END DO
24854 !c! Pitagoras
24855        R1 = dsqrt(R1)
24856
24857 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24858 !c!     &        +dhead(1,1,itypi,itypj))**2))
24859 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24860 !c!     &        +dhead(2,1,itypi,itypj))**2))
24861
24862 !c!-------------------------------------------------------------------
24863 !c! ecl
24864        sparrow  = w1  *  om1
24865        hawk     = w2 *  (1.0d0 - sqom2)
24866        Ecl = sparrow / Rhead**2.0d0 &
24867          - hawk    / Rhead**4.0d0
24868 !c!-------------------------------------------------------------------
24869 !c! derivative of ecl is Gcl
24870 !c! dF/dr part
24871        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
24872             + 4.0d0 * hawk    / Rhead**5.0d0
24873 !c! dF/dom1
24874        dGCLdOM1 = (w1) / (Rhead**2.0d0)
24875 !c! dF/dom2
24876        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
24877 !c--------------------------------------------------------------------
24878 !c Polarization energy
24879 !c Epol
24880        MomoFac1 = (1.0d0 - chi1 * sqom2)
24881        RR1  = R1 * R1 / MomoFac1
24882        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24883        fgb1 = sqrt( RR1 + a12sq * ee1)
24884 !       eps_inout_fac=0.0d0
24885        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
24886 ! derivative of Epol is Gpol...
24887        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
24888             / (fgb1 ** 5.0d0)
24889        dFGBdR1 = ( (R1 / MomoFac1) &
24890            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
24891            / ( 2.0d0 * fgb1 )
24892        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24893              * (2.0d0 - 0.5d0 * ee1) ) &
24894              / (2.0d0 * fgb1)
24895        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24896 !       dPOLdR1 = 0.0d0
24897        dPOLdOM1 = 0.0d0
24898        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
24899        DO k = 1, 3
24900       erhead(k) = Rhead_distance(k)/Rhead
24901       erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
24902        END DO
24903
24904        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24905        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24906        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24907 !       bat=0.0d0
24908        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
24909        facd1 = d1i * vbld_inv(i+nres)
24910        facd2 = d1j * vbld_inv(j+nres)
24911 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24912
24913        DO k = 1, 3
24914       hawk = (erhead_tail(k,1) + &
24915       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
24916 !        facd1=0.0d0
24917 !        facd2=0.0d0
24918       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24919       gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
24920                - dGCLdR * pom &
24921                - dPOLdR1 *  (erhead_tail(k,1))
24922 !     &             - dGLJdR * pom
24923
24924       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24925       gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
24926                + dGCLdR * pom  &
24927                + dPOLdR1 * (erhead_tail(k,1))
24928 !     &             + dGLJdR * pom
24929
24930
24931       gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
24932               - dGCLdR * erhead(k) &
24933               - dPOLdR1 * erhead_tail(k,1)
24934 !     &             - dGLJdR * erhead(k)
24935
24936       gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
24937               + dGCLdR * erhead(k)  &
24938               + dPOLdR1 * erhead_tail(k,1)
24939 !     &             + dGLJdR * erhead(k)
24940
24941        END DO
24942        endif
24943 !       print *,i,j,evdwij,epol,Fcav,ECL
24944        escbase=escbase+evdwij+epol+Fcav+ECL
24945        call sc_grad_scbase
24946        enddo
24947       enddo
24948
24949       return
24950       end subroutine eprot_sc_base
24951       SUBROUTINE sc_grad_scbase
24952       use calc_data
24953
24954        real (kind=8) :: dcosom1(3),dcosom2(3)
24955        eom1  =    &
24956             eps2der * eps2rt_om1   &
24957           - 2.0D0 * alf1 * eps3der &
24958           + sigder * sigsq_om1     &
24959           + dCAVdOM1               &
24960           + dGCLdOM1               &
24961           + dPOLdOM1
24962
24963        eom2  =  &
24964             eps2der * eps2rt_om2   &
24965           + 2.0D0 * alf2 * eps3der &
24966           + sigder * sigsq_om2     &
24967           + dCAVdOM2               &
24968           + dGCLdOM2               &
24969           + dPOLdOM2
24970
24971        eom12 =    &
24972             evdwij  * eps1_om12     &
24973           + eps2der * eps2rt_om12   &
24974           - 2.0D0 * alf12 * eps3der &
24975           + sigder *sigsq_om12      &
24976           + dCAVdOM12               &
24977           + dGCLdOM12
24978
24979 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24980 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24981 !               gg(1),gg(2),"rozne"
24982        DO k = 1, 3
24983       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24984       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24985       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24986       gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
24987              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
24988              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24989       gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
24990              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
24991              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24992       gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
24993       gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
24994        END DO
24995        RETURN
24996       END SUBROUTINE sc_grad_scbase
24997
24998
24999       subroutine epep_sc_base(epepbase)
25000       use calc_data
25001       logical :: lprn
25002 !el local variables
25003       integer :: iint,itypi,itypi1,itypj,subchap
25004       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25005       real(kind=8) :: evdw,sig0ij
25006       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25007                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25008                 sslipi,sslipj,faclip
25009       integer :: ii
25010       real(kind=8) :: fracinbuf
25011        real (kind=8) :: epepbase
25012        real (kind=8),dimension(4):: ener
25013        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25014        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25015       sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
25016       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25017       dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
25018       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25019       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25020       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
25021        real(kind=8),dimension(3,2)::chead,erhead_tail
25022        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25023        integer troll
25024        eps_out=80.0d0
25025        epepbase=0.0d0
25026 !       do i=1,nres_molec(1)-1
25027       do i=ibond_start,ibond_end
25028       if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
25029 !C        itypi  = itype(i,1)
25030       dxi    = dc_norm(1,i)
25031       dyi    = dc_norm(2,i)
25032       dzi    = dc_norm(3,i)
25033 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
25034       dsci_inv = vbld_inv(i+1)/2.0
25035       xi=(c(1,i)+c(1,i+1))/2.0
25036       yi=(c(2,i)+c(2,i+1))/2.0
25037       zi=(c(3,i)+c(3,i+1))/2.0
25038         call to_box(xi,yi,zi)
25039        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
25040          itypj= itype(j,2)
25041          if (itype(j,2).eq.ntyp1_molec(2))cycle
25042          xj=c(1,j+nres)
25043          yj=c(2,j+nres)
25044          zj=c(3,j+nres)
25045                 call to_box(xj,yj,zj)
25046       xj=boxshift(xj-xi,boxxsize)
25047       yj=boxshift(yj-yi,boxysize)
25048       zj=boxshift(zj-zi,boxzsize)
25049         dist_init=xj**2+yj**2+zj**2
25050         dxj = dc_norm( 1, nres+j )
25051         dyj = dc_norm( 2, nres+j )
25052         dzj = dc_norm( 3, nres+j )
25053 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
25054 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
25055
25056 ! Gay-berne var's
25057         sig0ij = sigma_pepbase(itypj )
25058         chi1   = chi_pepbase(itypj,1 )
25059         chi2   = chi_pepbase(itypj,2 )
25060 !          chi1=0.0d0
25061 !          chi2=0.0d0
25062         chi12  = chi1 * chi2
25063         chip1  = chipp_pepbase(itypj,1 )
25064         chip2  = chipp_pepbase(itypj,2 )
25065 !          chip1=0.0d0
25066 !          chip2=0.0d0
25067         chip12 = chip1 * chip2
25068         chis1 = chis_pepbase(itypj,1)
25069         chis2 = chis_pepbase(itypj,2)
25070         chis12 = chis1 * chis2
25071         sig1 = sigmap1_pepbase(itypj)
25072         sig2 = sigmap2_pepbase(itypj)
25073 !       write (*,*) "sig1 = ", sig1
25074 !       write (*,*) "sig2 = ", sig2
25075        DO k = 1,3
25076 ! location of polar head is computed by taking hydrophobic centre
25077 ! and moving by a d1 * dc_norm vector
25078 ! see unres publications for very informative images
25079       chead(k,1) = (c(k,i)+c(k,i+1))/2.0
25080 ! + d1i * dc_norm(k, i+nres)
25081       chead(k,2) = c(k, j+nres)
25082 ! + d1j * dc_norm(k, j+nres)
25083 ! distance
25084 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25085 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25086       Rhead_distance(k) = chead(k,2) - chead(k,1)
25087 !        print *,gvdwc_pepbase(k,i)
25088
25089        END DO
25090        Rhead = dsqrt( &
25091         (Rhead_distance(1)*Rhead_distance(1)) &
25092       + (Rhead_distance(2)*Rhead_distance(2)) &
25093       + (Rhead_distance(3)*Rhead_distance(3)))
25094
25095 ! alpha factors from Fcav/Gcav
25096         b1 = alphasur_pepbase(1,itypj)
25097 !          b1=0.0d0
25098         b2 = alphasur_pepbase(2,itypj)
25099         b3 = alphasur_pepbase(3,itypj)
25100         b4 = alphasur_pepbase(4,itypj)
25101         alf1   = 0.0d0
25102         alf2   = 0.0d0
25103         alf12  = 0.0d0
25104         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25105 !          print *,i,j,rrij
25106         rij  = dsqrt(rrij)
25107 !----------------------------
25108        evdwij = 0.0d0
25109        ECL = 0.0d0
25110        Elj = 0.0d0
25111        Equad = 0.0d0
25112        Epol = 0.0d0
25113        Fcav=0.0d0
25114        eheadtail = 0.0d0
25115        dGCLdOM1 = 0.0d0
25116        dGCLdOM2 = 0.0d0
25117        dGCLdOM12 = 0.0d0
25118        dPOLdOM1 = 0.0d0
25119        dPOLdOM2 = 0.0d0
25120         Fcav = 0.0d0
25121         dFdR = 0.0d0
25122         dCAVdOM1  = 0.0d0
25123         dCAVdOM2  = 0.0d0
25124         dCAVdOM12 = 0.0d0
25125         dscj_inv = vbld_inv(j+nres)
25126         CALL sc_angular
25127 ! this should be in elgrad_init but om's are calculated by sc_angular
25128 ! which in turn is used by older potentials
25129 ! om = omega, sqom = om^2
25130         sqom1  = om1 * om1
25131         sqom2  = om2 * om2
25132         sqom12 = om12 * om12
25133
25134 ! now we calculate EGB - Gey-Berne
25135 ! It will be summed up in evdwij and saved in evdw
25136         sigsq     = 1.0D0  / sigsq
25137         sig       = sig0ij * dsqrt(sigsq)
25138         rij_shift = 1.0/rij - sig + sig0ij
25139         IF (rij_shift.le.0.0D0) THEN
25140          evdw = 1.0D20
25141          RETURN
25142         END IF
25143         sigder = -sig * sigsq
25144         rij_shift = 1.0D0 / rij_shift
25145         fac       = rij_shift**expon
25146         c1        = fac  * fac * aa_pepbase(itypj)
25147 !          c1        = 0.0d0
25148         c2        = fac  * bb_pepbase(itypj)
25149 !          c2        = 0.0d0
25150         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25151         eps2der   = eps3rt * evdwij
25152         eps3der   = eps2rt * evdwij
25153 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25154         evdwij    = eps2rt * eps3rt * evdwij
25155         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25156         fac    = -expon * (c1 + evdwij) * rij_shift
25157         sigder = fac * sigder
25158 !          fac    = rij * fac
25159 ! Calculate distance derivative
25160         gg(1) =  fac
25161         gg(2) =  fac
25162         gg(3) =  fac
25163         fac = chis1 * sqom1 + chis2 * sqom2 &
25164         - 2.0d0 * chis12 * om1 * om2 * om12
25165 ! we will use pom later in Gcav, so dont mess with it!
25166         pom = 1.0d0 - chis1 * chis2 * sqom12
25167         Lambf = (1.0d0 - (fac / pom))
25168         Lambf = dsqrt(Lambf)
25169         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25170 !       write (*,*) "sparrow = ", sparrow
25171         Chif = 1.0d0/rij * sparrow
25172         ChiLambf = Chif * Lambf
25173         eagle = dsqrt(ChiLambf)
25174         bat = ChiLambf ** 11.0d0
25175         top = b1 * ( eagle + b2 * ChiLambf - b3 )
25176         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
25177         botsq = bot * bot
25178         Fcav = top / bot
25179 !          print *,i,j,Fcav
25180         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
25181         dbot = 12.0d0 * b4 * bat * Lambf
25182         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25183 !       dFdR = 0.0d0
25184 !      write (*,*) "dFcav/dR = ", dFdR
25185         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
25186         dbot = 12.0d0 * b4 * bat * Chif
25187         eagle = Lambf * pom
25188         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25189         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25190         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25191             * (chis2 * om2 * om12 - om1) / (eagle * pom)
25192
25193         dFdL = ((dtop * bot - top * dbot) / botsq)
25194 !       dFdL = 0.0d0
25195         dCAVdOM1  = dFdL * ( dFdOM1 )
25196         dCAVdOM2  = dFdL * ( dFdOM2 )
25197         dCAVdOM12 = dFdL * ( dFdOM12 )
25198
25199         ertail(1) = xj*rij
25200         ertail(2) = yj*rij
25201         ertail(3) = zj*rij
25202        DO k = 1, 3
25203 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25204 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25205       pom = ertail(k)
25206 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25207       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
25208               - (( dFdR + gg(k) ) * pom)/2.0
25209 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
25210 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
25211 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25212 !     &             - ( dFdR * pom )
25213       pom = ertail(k)
25214 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25215       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
25216               + (( dFdR + gg(k) ) * pom)
25217 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25218 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25219 !c!     &             + ( dFdR * pom )
25220
25221       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
25222               - (( dFdR + gg(k) ) * ertail(k))/2.0
25223 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
25224
25225 !c!     &             - ( dFdR * ertail(k))
25226
25227       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
25228               + (( dFdR + gg(k) ) * ertail(k))
25229 !c!     &             + ( dFdR * ertail(k))
25230
25231       gg(k) = 0.0d0
25232 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25233 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25234       END DO
25235
25236
25237        w1 = wdipdip_pepbase(1,itypj)
25238        w2 = -wdipdip_pepbase(3,itypj)/2.0
25239        w3 = wdipdip_pepbase(2,itypj)
25240 !       w1=0.0d0
25241 !       w2=0.0d0
25242 !c!-------------------------------------------------------------------
25243 !c! ECL
25244 !       w3=0.0d0
25245        fac = (om12 - 3.0d0 * om1 * om2)
25246        c1 = (w1 / (Rhead**3.0d0)) * fac
25247        c2 = (w2 / Rhead ** 6.0d0)  &
25248        * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
25249        c3= (w3/ Rhead ** 6.0d0)  &
25250        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
25251
25252        ECL = c1 - c2 + c3
25253
25254        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
25255        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
25256        * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
25257        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
25258        * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
25259
25260        dGCLdR = c1 - c2 + c3
25261 !c! dECL/dom1
25262        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
25263        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25264        * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
25265        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
25266        dGCLdOM1 = c1 - c2 + c3
25267 !c! dECL/dom2
25268        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
25269        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25270        * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
25271        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
25272
25273        dGCLdOM2 = c1 - c2 + c3
25274 !c! dECL/dom12
25275        c1 = w1 / (Rhead ** 3.0d0)
25276        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
25277        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
25278        dGCLdOM12 = c1 - c2 + c3
25279        DO k= 1, 3
25280       erhead(k) = Rhead_distance(k)/Rhead
25281        END DO
25282        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25283        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25284 !       facd1 = d1 * vbld_inv(i+nres)
25285 !       facd2 = d2 * vbld_inv(j+nres)
25286        DO k = 1, 3
25287
25288 !        pom = erhead(k)
25289 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25290 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
25291 !                  - dGCLdR * pom
25292       pom = erhead(k)
25293 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25294       gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
25295               + dGCLdR * pom
25296
25297       gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
25298               - dGCLdR * erhead(k)/2.0d0
25299 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
25300       gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
25301               - dGCLdR * erhead(k)/2.0d0
25302 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
25303       gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
25304               + dGCLdR * erhead(k)
25305        END DO
25306 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
25307        epepbase=epepbase+evdwij+Fcav+ECL
25308        call sc_grad_pepbase
25309        enddo
25310        enddo
25311       END SUBROUTINE epep_sc_base
25312       SUBROUTINE sc_grad_pepbase
25313       use calc_data
25314
25315        real (kind=8) :: dcosom1(3),dcosom2(3)
25316        eom1  =    &
25317             eps2der * eps2rt_om1   &
25318           - 2.0D0 * alf1 * eps3der &
25319           + sigder * sigsq_om1     &
25320           + dCAVdOM1               &
25321           + dGCLdOM1               &
25322           + dPOLdOM1
25323
25324        eom2  =  &
25325             eps2der * eps2rt_om2   &
25326           + 2.0D0 * alf2 * eps3der &
25327           + sigder * sigsq_om2     &
25328           + dCAVdOM2               &
25329           + dGCLdOM2               &
25330           + dPOLdOM2
25331
25332        eom12 =    &
25333             evdwij  * eps1_om12     &
25334           + eps2der * eps2rt_om12   &
25335           - 2.0D0 * alf12 * eps3der &
25336           + sigder *sigsq_om12      &
25337           + dCAVdOM12               &
25338           + dGCLdOM12
25339 !        om12=0.0
25340 !        eom12=0.0
25341 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
25342 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
25343 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25344 !                 *dsci_inv*2.0
25345 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
25346 !               gg(1),gg(2),"rozne"
25347        DO k = 1, 3
25348       dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
25349       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25350       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25351       gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
25352              + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25353              *dsci_inv*2.0 &
25354              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25355       gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
25356              - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
25357              *dsci_inv*2.0 &
25358              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
25359 !         print *,eom12,eom2,om12,om2
25360 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
25361 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
25362       gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
25363              + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
25364              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25365       gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
25366        END DO
25367        RETURN
25368       END SUBROUTINE sc_grad_pepbase
25369       subroutine eprot_sc_phosphate(escpho)
25370       use calc_data
25371 !      implicit real*8 (a-h,o-z)
25372 !      include 'DIMENSIONS'
25373 !      include 'COMMON.GEO'
25374 !      include 'COMMON.VAR'
25375 !      include 'COMMON.LOCAL'
25376 !      include 'COMMON.CHAIN'
25377 !      include 'COMMON.DERIV'
25378 !      include 'COMMON.NAMES'
25379 !      include 'COMMON.INTERACT'
25380 !      include 'COMMON.IOUNITS'
25381 !      include 'COMMON.CALC'
25382 !      include 'COMMON.CONTROL'
25383 !      include 'COMMON.SBRIDGE'
25384       logical :: lprn
25385 !el local variables
25386       integer :: iint,itypi,itypi1,itypj,subchap
25387       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25388       real(kind=8) :: evdw,sig0ij,aa,bb
25389       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25390                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
25391                 sslipi,sslipj,faclip,alpha_sco
25392       integer :: ii
25393       real(kind=8) :: fracinbuf
25394        real (kind=8) :: escpho
25395        real (kind=8),dimension(4):: ener
25396        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25397        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25398       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
25399       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25400       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
25401       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25402       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25403       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
25404        real(kind=8),dimension(3,2)::chead,erhead_tail
25405        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25406        integer troll
25407        eps_out=80.0d0
25408        escpho=0.0d0
25409 !       do i=1,nres_molec(1)
25410       do i=ibond_start,ibond_end
25411       if (itype(i,1).eq.ntyp1_molec(1)) cycle
25412       itypi  = itype(i,1)
25413       dxi    = dc_norm(1,nres+i)
25414       dyi    = dc_norm(2,nres+i)
25415       dzi    = dc_norm(3,nres+i)
25416       dsci_inv = vbld_inv(i+nres)
25417       xi=c(1,nres+i)
25418       yi=c(2,nres+i)
25419       zi=c(3,nres+i)
25420        call to_box(xi,yi,zi)
25421       call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
25422        do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
25423          itypj= itype(j,2)
25424          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
25425           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
25426          xj=(c(1,j)+c(1,j+1))/2.0
25427          yj=(c(2,j)+c(2,j+1))/2.0
25428          zj=(c(3,j)+c(3,j+1))/2.0
25429      call to_box(xj,yj,zj)
25430 !     call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
25431 !      aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25432 !       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25433 !      bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
25434 !       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
25435       xj=boxshift(xj-xi,boxxsize)
25436       yj=boxshift(yj-yi,boxysize)
25437       zj=boxshift(zj-zi,boxzsize)
25438           dxj = dc_norm( 1,j )
25439         dyj = dc_norm( 2,j )
25440         dzj = dc_norm( 3,j )
25441         dscj_inv = vbld_inv(j+1)
25442
25443 ! Gay-berne var's
25444         sig0ij = sigma_scpho(itypi )
25445         chi1   = chi_scpho(itypi,1 )
25446         chi2   = chi_scpho(itypi,2 )
25447 !          chi1=0.0d0
25448 !          chi2=0.0d0
25449         chi12  = chi1 * chi2
25450         chip1  = chipp_scpho(itypi,1 )
25451         chip2  = chipp_scpho(itypi,2 )
25452 !          chip1=0.0d0
25453 !          chip2=0.0d0
25454         chip12 = chip1 * chip2
25455         chis1 = chis_scpho(itypi,1)
25456         chis2 = chis_scpho(itypi,2)
25457         chis12 = chis1 * chis2
25458         sig1 = sigmap1_scpho(itypi)
25459         sig2 = sigmap2_scpho(itypi)
25460 !       write (*,*) "sig1 = ", sig1
25461 !       write (*,*) "sig1 = ", sig1
25462 !       write (*,*) "sig2 = ", sig2
25463 ! alpha factors from Fcav/Gcav
25464         alf1   = 0.0d0
25465         alf2   = 0.0d0
25466         alf12  = 0.0d0
25467         a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
25468
25469         b1 = alphasur_scpho(1,itypi)
25470 !          b1=0.0d0
25471         b2 = alphasur_scpho(2,itypi)
25472         b3 = alphasur_scpho(3,itypi)
25473         b4 = alphasur_scpho(4,itypi)
25474 ! used to determine whether we want to do quadrupole calculations
25475 ! used by Fgb
25476        eps_in = epsintab_scpho(itypi)
25477        if (eps_in.eq.0.0) eps_in=1.0
25478        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25479 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
25480 !-------------------------------------------------------------------
25481 ! tail location and distance calculations
25482         d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
25483         d1j = 0.0
25484        DO k = 1,3
25485 ! location of polar head is computed by taking hydrophobic centre
25486 ! and moving by a d1 * dc_norm vector
25487 ! see unres publications for very informative images
25488       chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
25489       chead(k,2) = (c(k, j) + c(k, j+1))/2.0
25490 ! distance
25491 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25492 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25493       Rhead_distance(k) = chead(k,2) - chead(k,1)
25494        END DO
25495 ! pitagoras (root of sum of squares)
25496        Rhead = dsqrt( &
25497         (Rhead_distance(1)*Rhead_distance(1)) &
25498       + (Rhead_distance(2)*Rhead_distance(2)) &
25499       + (Rhead_distance(3)*Rhead_distance(3)))
25500        Rhead_sq=Rhead**2.0
25501 !-------------------------------------------------------------------
25502 ! zero everything that should be zero'ed
25503        evdwij = 0.0d0
25504        ECL = 0.0d0
25505        Elj = 0.0d0
25506        Equad = 0.0d0
25507        Epol = 0.0d0
25508        Fcav=0.0d0
25509        eheadtail = 0.0d0
25510        dGCLdR=0.0d0
25511        dGCLdOM1 = 0.0d0
25512        dGCLdOM2 = 0.0d0
25513        dGCLdOM12 = 0.0d0
25514        dPOLdOM1 = 0.0d0
25515        dPOLdOM2 = 0.0d0
25516         Fcav = 0.0d0
25517         dFdR = 0.0d0
25518         dCAVdOM1  = 0.0d0
25519         dCAVdOM2  = 0.0d0
25520         dCAVdOM12 = 0.0d0
25521         dscj_inv = vbld_inv(j+1)/2.0
25522 !dhead_scbasej(itypi,itypj)
25523 !          print *,i,j,dscj_inv,dsci_inv
25524 ! rij holds 1/(distance of Calpha atoms)
25525         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25526         rij  = dsqrt(rrij)
25527 !----------------------------
25528         CALL sc_angular
25529 ! this should be in elgrad_init but om's are calculated by sc_angular
25530 ! which in turn is used by older potentials
25531 ! om = omega, sqom = om^2
25532         sqom1  = om1 * om1
25533         sqom2  = om2 * om2
25534         sqom12 = om12 * om12
25535
25536 ! now we calculate EGB - Gey-Berne
25537 ! It will be summed up in evdwij and saved in evdw
25538         sigsq     = 1.0D0  / sigsq
25539         sig       = sig0ij * dsqrt(sigsq)
25540 !          rij_shift = 1.0D0  / rij - sig + sig0ij
25541         rij_shift = 1.0/rij - sig + sig0ij
25542         IF (rij_shift.le.0.0D0) THEN
25543          evdw = 1.0D20
25544          RETURN
25545         END IF
25546         sigder = -sig * sigsq
25547         rij_shift = 1.0D0 / rij_shift
25548         fac       = rij_shift**expon
25549         c1        = fac  * fac * aa_scpho(itypi)
25550 !          c1        = 0.0d0
25551         c2        = fac  * bb_scpho(itypi)
25552 !          c2        = 0.0d0
25553         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
25554         eps2der   = eps3rt * evdwij
25555         eps3der   = eps2rt * evdwij
25556 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
25557         evdwij    = eps2rt * eps3rt * evdwij
25558         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
25559         fac    = -expon * (c1 + evdwij) * rij_shift
25560         sigder = fac * sigder
25561 !          fac    = rij * fac
25562 ! Calculate distance derivative
25563         gg(1) =  fac
25564         gg(2) =  fac
25565         gg(3) =  fac
25566         fac = chis1 * sqom1 + chis2 * sqom2 &
25567         - 2.0d0 * chis12 * om1 * om2 * om12
25568 ! we will use pom later in Gcav, so dont mess with it!
25569         pom = 1.0d0 - chis1 * chis2 * sqom12
25570         Lambf = (1.0d0 - (fac / pom))
25571         Lambf = dsqrt(Lambf)
25572         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
25573 !       write (*,*) "sparrow = ", sparrow
25574         Chif = 1.0d0/rij * sparrow
25575         ChiLambf = Chif * Lambf
25576         eagle = dsqrt(ChiLambf)
25577         bat = ChiLambf ** 11.0d0
25578         top = b1 * ( eagle + b2 * ChiLambf - b3 )
25579         bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
25580         botsq = bot * bot
25581         Fcav = top / bot
25582         dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
25583         dbot = 12.0d0 * b4 * bat * Lambf
25584         dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
25585 !       dFdR = 0.0d0
25586 !      write (*,*) "dFcav/dR = ", dFdR
25587         dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
25588         dbot = 12.0d0 * b4 * bat * Chif
25589         eagle = Lambf * pom
25590         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
25591         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
25592         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
25593             * (chis2 * om2 * om12 - om1) / (eagle * pom)
25594
25595         dFdL = ((dtop * bot - top * dbot) / botsq)
25596 !       dFdL = 0.0d0
25597         dCAVdOM1  = dFdL * ( dFdOM1 )
25598         dCAVdOM2  = dFdL * ( dFdOM2 )
25599         dCAVdOM12 = dFdL * ( dFdOM12 )
25600
25601         ertail(1) = xj*rij
25602         ertail(2) = yj*rij
25603         ertail(3) = zj*rij
25604        DO k = 1, 3
25605 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25606 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25607 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
25608
25609       pom = ertail(k)
25610 !        print *,pom,gg(k),dFdR
25611 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
25612       gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
25613               - (( dFdR + gg(k) ) * pom)
25614 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
25615 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25616 !     &             - ( dFdR * pom )
25617 !        pom = ertail(k)
25618 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
25619 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
25620 !                  + (( dFdR + gg(k) ) * pom)
25621 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25622 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25623 !c!     &             + ( dFdR * pom )
25624
25625       gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
25626               - (( dFdR + gg(k) ) * ertail(k))
25627 !c!     &             - ( dFdR * ertail(k))
25628
25629       gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
25630               + (( dFdR + gg(k) ) * ertail(k))/2.0
25631
25632       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
25633               + (( dFdR + gg(k) ) * ertail(k))/2.0
25634
25635 !c!     &             + ( dFdR * ertail(k))
25636
25637       gg(k) = 0.0d0
25638       ENDDO
25639 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
25640 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
25641 !      alphapol1 = alphapol_scpho(itypi)
25642        if (wqq_scpho(itypi).ne.0.0) then
25643        Qij=wqq_scpho(itypi)/eps_in
25644        alpha_sco=1.d0/alphi_scpho(itypi)
25645 !       Qij=0.0
25646        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
25647 !c! derivative of Ecl is Gcl...
25648        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
25649             (Rhead*alpha_sco+1) ) / Rhead_sq
25650        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
25651        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
25652        w1        = wqdip_scpho(1,itypi)
25653        w2        = wqdip_scpho(2,itypi)
25654 !       w1=0.0d0
25655 !       w2=0.0d0
25656 !       pis       = sig0head_scbase(itypi,itypj)
25657 !       eps_head   = epshead_scbase(itypi,itypj)
25658 !c!-------------------------------------------------------------------
25659
25660 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25661 !c!     &        +dhead(1,1,itypi,itypj))**2))
25662 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25663 !c!     &        +dhead(2,1,itypi,itypj))**2))
25664
25665 !c!-------------------------------------------------------------------
25666 !c! ecl
25667        sparrow  = w1  *  om1
25668        hawk     = w2 *  (1.0d0 - sqom2)
25669        Ecl = sparrow / Rhead**2.0d0 &
25670          - hawk    / Rhead**4.0d0
25671 !c!-------------------------------------------------------------------
25672        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
25673          1.0/rij,sparrow
25674
25675 !c! derivative of ecl is Gcl
25676 !c! dF/dr part
25677        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
25678             + 4.0d0 * hawk    / Rhead**5.0d0
25679 !c! dF/dom1
25680        dGCLdOM1 = (w1) / (Rhead**2.0d0)
25681 !c! dF/dom2
25682        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
25683        endif
25684
25685 !c--------------------------------------------------------------------
25686 !c Polarization energy
25687 !c Epol
25688        R1 = 0.0d0
25689        DO k = 1, 3
25690 !c! Calculate head-to-tail distances tail is center of side-chain
25691       R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
25692        END DO
25693 !c! Pitagoras
25694        R1 = dsqrt(R1)
25695
25696       alphapol1 = alphapol_scpho(itypi)
25697 !      alphapol1=0.0
25698        MomoFac1 = (1.0d0 - chi2 * sqom1)
25699        RR1  = R1 * R1 / MomoFac1
25700        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25701 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
25702        fgb1 = sqrt( RR1 + a12sq * ee1)
25703 !       eps_inout_fac=0.0d0
25704        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
25705 ! derivative of Epol is Gpol...
25706        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
25707             / (fgb1 ** 5.0d0)
25708        dFGBdR1 = ( (R1 / MomoFac1) &
25709            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
25710            / ( 2.0d0 * fgb1 )
25711        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25712              * (2.0d0 - 0.5d0 * ee1) ) &
25713              / (2.0d0 * fgb1)
25714        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25715 !       dPOLdR1 = 0.0d0
25716 !       dPOLdOM1 = 0.0d0
25717        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
25718              * (2.0d0 - 0.5d0 * ee1) ) &
25719              / (2.0d0 * fgb1)
25720
25721        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
25722        dPOLdOM2 = 0.0
25723        DO k = 1, 3
25724       erhead(k) = Rhead_distance(k)/Rhead
25725       erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
25726        END DO
25727
25728        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25729        erdxj = scalar( erhead(1), dC_norm(1,j) )
25730        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25731 !       bat=0.0d0
25732        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
25733        facd1 = d1i * vbld_inv(i+nres)
25734        facd2 = d1j * vbld_inv(j)
25735 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25736
25737        DO k = 1, 3
25738       hawk = (erhead_tail(k,1) + &
25739       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
25740 !        facd1=0.0d0
25741 !        facd2=0.0d0
25742 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
25743 !                pom,(erhead_tail(k,1))
25744
25745 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
25746       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25747       gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
25748                - dGCLdR * pom &
25749                - dPOLdR1 *  (erhead_tail(k,1))
25750 !     &             - dGLJdR * pom
25751
25752       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
25753 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
25754 !                   + dGCLdR * pom  &
25755 !                   + dPOLdR1 * (erhead_tail(k,1))
25756 !     &             + dGLJdR * pom
25757
25758
25759       gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
25760               - dGCLdR * erhead(k) &
25761               - dPOLdR1 * erhead_tail(k,1)
25762 !     &             - dGLJdR * erhead(k)
25763
25764       gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
25765               + (dGCLdR * erhead(k)  &
25766               + dPOLdR1 * erhead_tail(k,1))/2.0
25767       gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
25768               + (dGCLdR * erhead(k)  &
25769               + dPOLdR1 * erhead_tail(k,1))/2.0
25770
25771 !     &             + dGLJdR * erhead(k)
25772 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
25773
25774        END DO
25775 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
25776        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
25777       "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
25778        escpho=escpho+evdwij+epol+Fcav+ECL
25779        call sc_grad_scpho
25780        enddo
25781
25782       enddo
25783
25784       return
25785       end subroutine eprot_sc_phosphate
25786       SUBROUTINE sc_grad_scpho
25787       use calc_data
25788
25789        real (kind=8) :: dcosom1(3),dcosom2(3)
25790        eom1  =    &
25791             eps2der * eps2rt_om1   &
25792           - 2.0D0 * alf1 * eps3der &
25793           + sigder * sigsq_om1     &
25794           + dCAVdOM1               &
25795           + dGCLdOM1               &
25796           + dPOLdOM1
25797
25798        eom2  =  &
25799             eps2der * eps2rt_om2   &
25800           + 2.0D0 * alf2 * eps3der &
25801           + sigder * sigsq_om2     &
25802           + dCAVdOM2               &
25803           + dGCLdOM2               &
25804           + dPOLdOM2
25805
25806        eom12 =    &
25807             evdwij  * eps1_om12     &
25808           + eps2der * eps2rt_om12   &
25809           - 2.0D0 * alf12 * eps3der &
25810           + sigder *sigsq_om12      &
25811           + dCAVdOM12               &
25812           + dGCLdOM12
25813 !        om12=0.0
25814 !        eom12=0.0
25815 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
25816 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
25817 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
25818 !                 *dsci_inv*2.0
25819 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
25820 !               gg(1),gg(2),"rozne"
25821        DO k = 1, 3
25822       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25823       dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
25824       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25825       gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
25826              + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
25827              *dscj_inv*2.0 &
25828              - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25829       gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
25830              - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
25831              *dscj_inv*2.0 &
25832              + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
25833       gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
25834              + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
25835              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25836
25837 !         print *,eom12,eom2,om12,om2
25838 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
25839 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
25840 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
25841 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
25842 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25843       gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
25844        END DO
25845        RETURN
25846       END SUBROUTINE sc_grad_scpho
25847       subroutine eprot_pep_phosphate(epeppho)
25848       use calc_data
25849 !      implicit real*8 (a-h,o-z)
25850 !      include 'DIMENSIONS'
25851 !      include 'COMMON.GEO'
25852 !      include 'COMMON.VAR'
25853 !      include 'COMMON.LOCAL'
25854 !      include 'COMMON.CHAIN'
25855 !      include 'COMMON.DERIV'
25856 !      include 'COMMON.NAMES'
25857 !      include 'COMMON.INTERACT'
25858 !      include 'COMMON.IOUNITS'
25859 !      include 'COMMON.CALC'
25860 !      include 'COMMON.CONTROL'
25861 !      include 'COMMON.SBRIDGE'
25862       logical :: lprn
25863 !el local variables
25864       integer :: iint,itypi,itypi1,itypj,subchap
25865       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
25866       real(kind=8) :: evdw,sig0ij
25867       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
25868                 dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
25869                 sslipi,sslipj,faclip
25870       integer :: ii
25871       real(kind=8) :: fracinbuf
25872        real (kind=8) :: epeppho
25873        real (kind=8),dimension(4):: ener
25874        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
25875        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
25876       sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
25877       Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
25878       dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
25879       r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
25880       dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
25881       sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
25882        real(kind=8),dimension(3,2)::chead,erhead_tail
25883        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
25884        integer troll
25885        real (kind=8) :: dcosom1(3),dcosom2(3)
25886        epeppho=0.0d0
25887 !       do i=1,nres_molec(1)
25888       do i=ibond_start,ibond_end
25889       if (itype(i,1).eq.ntyp1_molec(1)) cycle
25890       itypi  = itype(i,1)
25891       dsci_inv = vbld_inv(i+1)/2.0
25892       dxi    = dc_norm(1,i)
25893       dyi    = dc_norm(2,i)
25894       dzi    = dc_norm(3,i)
25895       xi=(c(1,i)+c(1,i+1))/2.0
25896       yi=(c(2,i)+c(2,i+1))/2.0
25897       zi=(c(3,i)+c(3,i+1))/2.0
25898                call to_box(xi,yi,zi)
25899
25900         do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
25901          itypj= itype(j,2)
25902          if ((itype(j,2).eq.ntyp1_molec(2)).or.&
25903           (itype(j+1,2).eq.ntyp1_molec(2))) cycle
25904          xj=(c(1,j)+c(1,j+1))/2.0
25905          yj=(c(2,j)+c(2,j+1))/2.0
25906          zj=(c(3,j)+c(3,j+1))/2.0
25907                 call to_box(xj,yj,zj)
25908       xj=boxshift(xj-xi,boxxsize)
25909       yj=boxshift(yj-yi,boxysize)
25910       zj=boxshift(zj-zi,boxzsize)
25911
25912         dist_init=xj**2+yj**2+zj**2
25913         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
25914         rij  = dsqrt(rrij)
25915         dxj = dc_norm( 1,j )
25916         dyj = dc_norm( 2,j )
25917         dzj = dc_norm( 3,j )
25918         dscj_inv = vbld_inv(j+1)/2.0
25919 ! Gay-berne var's
25920         sig0ij = sigma_peppho
25921 !          chi1=0.0d0
25922 !          chi2=0.0d0
25923         chi12  = chi1 * chi2
25924 !          chip1=0.0d0
25925 !          chip2=0.0d0
25926         chip12 = chip1 * chip2
25927 !          chis1 = 0.0d0
25928 !          chis2 = 0.0d0
25929         chis12 = chis1 * chis2
25930         sig1 = sigmap1_peppho
25931         sig2 = sigmap2_peppho
25932 !       write (*,*) "sig1 = ", sig1
25933 !       write (*,*) "sig1 = ", sig1
25934 !       write (*,*) "sig2 = ", sig2
25935 ! alpha factors from Fcav/Gcav
25936         alf1   = 0.0d0
25937         alf2   = 0.0d0
25938         alf12  = 0.0d0
25939         b1 = alphasur_peppho(1)
25940 !          b1=0.0d0
25941         b2 = alphasur_peppho(2)
25942         b3 = alphasur_peppho(3)
25943         b4 = alphasur_peppho(4)
25944         CALL sc_angular
25945        sqom1=om1*om1
25946        evdwij = 0.0d0
25947        ECL = 0.0d0
25948        Elj = 0.0d0
25949        Equad = 0.0d0
25950        Epol = 0.0d0
25951        Fcav=0.0d0
25952        eheadtail = 0.0d0
25953        dGCLdR=0.0d0
25954        dGCLdOM1 = 0.0d0
25955        dGCLdOM2 = 0.0d0
25956        dGCLdOM12 = 0.0d0
25957        dPOLdOM1 = 0.0d0
25958        dPOLdOM2 = 0.0d0
25959         Fcav = 0.0d0
25960         dFdR = 0.0d0
25961         dCAVdOM1  = 0.0d0
25962         dCAVdOM2  = 0.0d0
25963         dCAVdOM12 = 0.0d0
25964         rij_shift = rij
25965         fac       = rij_shift**expon
25966         c1        = fac  * fac * aa_peppho
25967 !          c1        = 0.0d0
25968         c2        = fac  * bb_peppho
25969 !          c2        = 0.0d0
25970         evdwij    =  c1 + c2
25971 ! Now cavity....................
25972        eagle = dsqrt(1.0/rij_shift)
25973        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
25974         bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
25975         botsq = bot * bot
25976         Fcav = top / bot
25977         dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
25978         dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
25979         dFdR = ((dtop * bot - top * dbot) / botsq)
25980        w1        = wqdip_peppho(1)
25981        w2        = wqdip_peppho(2)
25982 !       w1=0.0d0
25983 !       w2=0.0d0
25984 !       pis       = sig0head_scbase(itypi,itypj)
25985 !       eps_head   = epshead_scbase(itypi,itypj)
25986 !c!-------------------------------------------------------------------
25987
25988 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25989 !c!     &        +dhead(1,1,itypi,itypj))**2))
25990 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25991 !c!     &        +dhead(2,1,itypi,itypj))**2))
25992
25993 !c!-------------------------------------------------------------------
25994 !c! ecl
25995        sparrow  = w1  *  om1
25996        hawk     = w2 *  (1.0d0 - sqom1)
25997        Ecl = sparrow * rij_shift**2.0d0 &
25998          - hawk    * rij_shift**4.0d0
25999 !c!-------------------------------------------------------------------
26000 !c! derivative of ecl is Gcl
26001 !c! dF/dr part
26002 !       rij_shift=5.0
26003        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
26004             + 4.0d0 * hawk    * rij_shift**5.0d0
26005 !c! dF/dom1
26006        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
26007 !c! dF/dom2
26008        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
26009        eom1  =    dGCLdOM1+dGCLdOM2
26010        eom2  =    0.0
26011
26012         fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
26013 !          fac=0.0
26014         gg(1) =  fac*xj*rij
26015         gg(2) =  fac*yj*rij
26016         gg(3) =  fac*zj*rij
26017        do k=1,3
26018        gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
26019        gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
26020        gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
26021        gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
26022        gg(k)=0.0
26023        enddo
26024
26025       DO k = 1, 3
26026       dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
26027       dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
26028       gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
26029       gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
26030 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
26031       gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
26032 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
26033       gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
26034              - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
26035       gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
26036              + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
26037       enddo
26038        epeppho=epeppho+evdwij+Fcav+ECL
26039 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
26040        enddo
26041        enddo
26042       end subroutine eprot_pep_phosphate
26043 !!!!!!!!!!!!!!!!-------------------------------------------------------------
26044       subroutine emomo(evdw)
26045       use calc_data
26046       use comm_momo
26047 !      implicit real*8 (a-h,o-z)
26048 !      include 'DIMENSIONS'
26049 !      include 'COMMON.GEO'
26050 !      include 'COMMON.VAR'
26051 !      include 'COMMON.LOCAL'
26052 !      include 'COMMON.CHAIN'
26053 !      include 'COMMON.DERIV'
26054 !      include 'COMMON.NAMES'
26055 !      include 'COMMON.INTERACT'
26056 !      include 'COMMON.IOUNITS'
26057 !      include 'COMMON.CALC'
26058 !      include 'COMMON.CONTROL'
26059 !      include 'COMMON.SBRIDGE'
26060       logical :: lprn
26061 !el local variables
26062       integer :: iint,itypi1,subchap,isel
26063       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
26064       real(kind=8) :: evdw,aa,bb
26065       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
26066                 dist_temp, dist_init,ssgradlipi,ssgradlipj, &
26067                 sslipi,sslipj,faclip,alpha_sco
26068       integer :: ii
26069       real(kind=8) :: fracinbuf
26070        real (kind=8) :: escpho
26071        real (kind=8),dimension(4):: ener
26072        real(kind=8) :: b1,b2,egb
26073        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
26074       Lambf,&
26075       Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
26076       dFdOM2,dFdL,dFdOM12,&
26077       federmaus,&
26078       d1i,d1j
26079 !       real(kind=8),dimension(3,2)::erhead_tail
26080 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
26081        real(kind=8) ::  facd4, adler, Fgb, facd3
26082        integer troll,jj,istate
26083        real (kind=8) :: dcosom1(3),dcosom2(3)
26084        evdw=0.0d0
26085        eps_out=80.0d0
26086        sss_ele_cut=1.0d0
26087 !       print *,"EVDW KURW",evdw,nres
26088       do i=iatsc_s,iatsc_e
26089 !        print *,"I am in EVDW",i
26090       itypi=iabs(itype(i,1))
26091 !        if (i.ne.47) cycle
26092       if (itypi.eq.ntyp1) cycle
26093       itypi1=iabs(itype(i+1,1))
26094       xi=c(1,nres+i)
26095       yi=c(2,nres+i)
26096       zi=c(3,nres+i)
26097         call to_box(xi,yi,zi)
26098         call lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
26099 !       endif
26100 !       print *, sslipi,ssgradlipi
26101       dxi=dc_norm(1,nres+i)
26102       dyi=dc_norm(2,nres+i)
26103       dzi=dc_norm(3,nres+i)
26104 !        dsci_inv=dsc_inv(itypi)
26105       dsci_inv=vbld_inv(i+nres)
26106 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
26107 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
26108 !
26109 ! Calculate SC interaction energy.
26110 !
26111       do iint=1,nint_gr(i)
26112         do j=istart(i,iint),iend(i,iint)
26113 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
26114           IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
26115             call dyn_ssbond_ene(i,j,evdwij)
26116             evdw=evdw+evdwij
26117             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
26118                         'evdw',i,j,evdwij,' ss'
26119 !              if (energy_dec) write (iout,*) &
26120 !                              'evdw',i,j,evdwij,' ss'
26121            do k=j+1,iend(i,iint)
26122 !C search over all next residues
26123             if (dyn_ss_mask(k)) then
26124 !C check if they are cysteins
26125 !C              write(iout,*) 'k=',k
26126
26127 !c              write(iout,*) "PRZED TRI", evdwij
26128 !               evdwij_przed_tri=evdwij
26129             call triple_ssbond_ene(i,j,k,evdwij)
26130 !c               if(evdwij_przed_tri.ne.evdwij) then
26131 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
26132 !c               endif
26133
26134 !c              write(iout,*) "PO TRI", evdwij
26135 !C call the energy function that removes the artifical triple disulfide
26136 !C bond the soubroutine is located in ssMD.F
26137             evdw=evdw+evdwij
26138             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
26139                       'evdw',i,j,evdwij,'tss'
26140             endif!dyn_ss_mask(k)
26141            enddo! k
26142           ELSE
26143 !el            ind=ind+1
26144           itypj=iabs(itype(j,1))
26145           if (itypj.eq.ntyp1) cycle
26146            CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
26147
26148 !             if (j.ne.78) cycle
26149 !            dscj_inv=dsc_inv(itypj)
26150           dscj_inv=vbld_inv(j+nres)
26151          xj=c(1,j+nres)
26152          yj=c(2,j+nres)
26153          zj=c(3,j+nres)
26154      call to_box(xj,yj,zj)
26155      call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
26156 !      write(iout,*) "KRUWA", i,j
26157       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
26158       +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
26159       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
26160       +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
26161       xj=boxshift(xj-xi,boxxsize)
26162       yj=boxshift(yj-yi,boxysize)
26163       zj=boxshift(zj-zi,boxzsize)
26164         dxj = dc_norm( 1, nres+j )
26165         dyj = dc_norm( 2, nres+j )
26166         dzj = dc_norm( 3, nres+j )
26167 !          print *,i,j,itypi,itypj
26168 !          d1i=0.0d0
26169 !          d1j=0.0d0
26170 !          BetaT = 1.0d0 / (298.0d0 * Rb)
26171 ! Gay-berne var's
26172 !1!          sig0ij = sigma_scsc( itypi,itypj )
26173 !          chi1=0.0d0
26174 !          chi2=0.0d0
26175 !          chip1=0.0d0
26176 !          chip2=0.0d0
26177 ! not used by momo potential, but needed by sc_angular which is shared
26178 ! by all energy_potential subroutines
26179         alf1   = 0.0d0
26180         alf2   = 0.0d0
26181         alf12  = 0.0d0
26182         a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
26183 !       a12sq = a12sq * a12sq
26184 ! charge of amino acid itypi is...
26185         chis1 = chis(itypi,itypj)
26186         chis2 = chis(itypj,itypi)
26187         chis12 = chis1 * chis2
26188         sig1 = sigmap1(itypi,itypj)
26189         sig2 = sigmap2(itypi,itypj)
26190 !       write (*,*) "sig1 = ", sig1
26191 !          chis1=0.0
26192 !          chis2=0.0
26193 !                    chis12 = chis1 * chis2
26194 !          sig1=0.0
26195 !          sig2=0.0
26196 !       write (*,*) "sig2 = ", sig2
26197 ! alpha factors from Fcav/Gcav
26198         b1cav = alphasur(1,itypi,itypj)
26199 !          b1cav=0.0d0
26200         b2cav = alphasur(2,itypi,itypj)
26201         b3cav = alphasur(3,itypi,itypj)
26202         b4cav = alphasur(4,itypi,itypj)
26203 ! used to determine whether we want to do quadrupole calculations
26204        eps_in = epsintab(itypi,itypj)
26205        if (eps_in.eq.0.0) eps_in=1.0
26206
26207        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
26208        Rtail = 0.0d0
26209 !       dtail(1,itypi,itypj)=0.0
26210 !       dtail(2,itypi,itypj)=0.0
26211
26212        DO k = 1, 3
26213       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
26214       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
26215        END DO
26216 !c! tail distances will be themselves usefull elswhere
26217 !c1 (in Gcav, for example)
26218        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
26219        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
26220        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
26221        Rtail = dsqrt( &
26222         (Rtail_distance(1)*Rtail_distance(1)) &
26223       + (Rtail_distance(2)*Rtail_distance(2)) &
26224       + (Rtail_distance(3)*Rtail_distance(3)))
26225
26226 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
26227 !-------------------------------------------------------------------
26228 ! tail location and distance calculations
26229        d1 = dhead(1, 1, itypi, itypj)
26230        d2 = dhead(2, 1, itypi, itypj)
26231
26232        DO k = 1,3
26233 ! location of polar head is computed by taking hydrophobic centre
26234 ! and moving by a d1 * dc_norm vector
26235 ! see unres publications for very informative images
26236       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26237       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26238 ! distance
26239 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
26240 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
26241       Rhead_distance(k) = chead(k,2) - chead(k,1)
26242        END DO
26243 ! pitagoras (root of sum of squares)
26244        Rhead = dsqrt( &
26245         (Rhead_distance(1)*Rhead_distance(1)) &
26246       + (Rhead_distance(2)*Rhead_distance(2)) &
26247       + (Rhead_distance(3)*Rhead_distance(3)))
26248 !-------------------------------------------------------------------
26249 ! zero everything that should be zero'ed
26250        evdwij = 0.0d0
26251        ECL = 0.0d0
26252        Elj = 0.0d0
26253        Equad = 0.0d0
26254        Epol = 0.0d0
26255        Fcav=0.0d0
26256        eheadtail = 0.0d0
26257        dGCLdOM1 = 0.0d0
26258        dGCLdOM2 = 0.0d0
26259        dGCLdOM12 = 0.0d0
26260        dPOLdOM1 = 0.0d0
26261        dPOLdOM2 = 0.0d0
26262         Fcav = 0.0d0
26263         dFdR = 0.0d0
26264         dCAVdOM1  = 0.0d0
26265         dCAVdOM2  = 0.0d0
26266         dCAVdOM12 = 0.0d0
26267         dscj_inv = vbld_inv(j+nres)
26268 !          print *,i,j,dscj_inv,dsci_inv
26269 ! rij holds 1/(distance of Calpha atoms)
26270         rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
26271         rij  = dsqrt(rrij)
26272 !----------------------------
26273         CALL sc_angular
26274 ! this should be in elgrad_init but om's are calculated by sc_angular
26275 ! which in turn is used by older potentials
26276 ! om = omega, sqom = om^2
26277         sqom1  = om1 * om1
26278         sqom2  = om2 * om2
26279         sqom12 = om12 * om12
26280
26281 ! now we calculate EGB - Gey-Berne
26282 ! It will be summed up in evdwij and saved in evdw
26283         sigsq     = 1.0D0  / sigsq
26284         sig       = sig0ij * dsqrt(sigsq)
26285 !          rij_shift = 1.0D0  / rij - sig + sig0ij
26286         rij_shift = Rtail - sig + sig0ij
26287         IF (rij_shift.le.0.0D0) THEN
26288          evdw = 1.0D20
26289          RETURN
26290         END IF
26291         sigder = -sig * sigsq
26292         rij_shift = 1.0D0 / rij_shift
26293         fac       = rij_shift**expon
26294         c1        = fac  * fac * aa_aq(itypi,itypj)
26295 !          print *,"ADAM",aa_aq(itypi,itypj)
26296
26297 !          c1        = 0.0d0
26298         c2        = fac  * bb_aq(itypi,itypj)
26299 !          c2        = 0.0d0
26300         evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
26301         eps2der   = eps3rt * evdwij
26302         eps3der   = eps2rt * evdwij
26303 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
26304         evdwij    = eps2rt * eps3rt * evdwij
26305 !#ifdef TSCSC
26306 !          IF (bb_aq(itypi,itypj).gt.0) THEN
26307 !           evdw_p = evdw_p + evdwij
26308 !          ELSE
26309 !           evdw_m = evdw_m + evdwij
26310 !          END IF
26311 !#else
26312         evdw = evdw  &
26313             + evdwij
26314 !#endif
26315
26316         c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
26317         fac    = -expon * (c1 + evdwij) * rij_shift
26318         sigder = fac * sigder
26319 !          fac    = rij * fac
26320 ! Calculate distance derivative
26321         gg(1) =  fac
26322         gg(2) =  fac
26323         gg(3) =  fac
26324 !          if (b2.gt.0.0) then
26325         fac = chis1 * sqom1 + chis2 * sqom2 &
26326         - 2.0d0 * chis12 * om1 * om2 * om12
26327 ! we will use pom later in Gcav, so dont mess with it!
26328         pom = 1.0d0 - chis1 * chis2 * sqom12
26329         Lambf = (1.0d0 - (fac / pom))
26330 !          print *,"fac,pom",fac,pom,Lambf
26331         Lambf = dsqrt(Lambf)
26332         sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
26333 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
26334 !       write (*,*) "sparrow = ", sparrow
26335         Chif = Rtail * sparrow
26336 !           print *,"rij,sparrow",rij , sparrow
26337         ChiLambf = Chif * Lambf
26338         eagle = dsqrt(ChiLambf)
26339         bat = ChiLambf ** 11.0d0
26340         top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
26341         bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
26342         botsq = bot * bot
26343 !          print *,top,bot,"bot,top",ChiLambf,Chif
26344         Fcav = top / bot
26345
26346        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
26347        dbot = 12.0d0 * b4cav * bat * Lambf
26348        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
26349
26350         dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
26351         dbot = 12.0d0 * b4cav * bat * Chif
26352         eagle = Lambf * pom
26353         dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
26354         dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
26355         dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
26356             * (chis2 * om2 * om12 - om1) / (eagle * pom)
26357
26358         dFdL = ((dtop * bot - top * dbot) / botsq)
26359 !       dFdL = 0.0d0
26360         dCAVdOM1  = dFdL * ( dFdOM1 )
26361         dCAVdOM2  = dFdL * ( dFdOM2 )
26362         dCAVdOM12 = dFdL * ( dFdOM12 )
26363
26364        DO k= 1, 3
26365       ertail(k) = Rtail_distance(k)/Rtail
26366        END DO
26367        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
26368        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
26369        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26370        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26371        DO k = 1, 3
26372 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
26373 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
26374       pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
26375       gvdwx(k,i) = gvdwx(k,i) &
26376               - (( dFdR + gg(k) ) * pom)
26377 !c!     &             - ( dFdR * pom )
26378       pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
26379       gvdwx(k,j) = gvdwx(k,j)   &
26380               + (( dFdR + gg(k) ) * pom)
26381 !c!     &             + ( dFdR * pom )
26382
26383       gvdwc(k,i) = gvdwc(k,i)  &
26384               - (( dFdR + gg(k) ) * ertail(k))
26385 !c!     &             - ( dFdR * ertail(k))
26386
26387       gvdwc(k,j) = gvdwc(k,j) &
26388               + (( dFdR + gg(k) ) * ertail(k))
26389 !c!     &             + ( dFdR * ertail(k))
26390
26391       gg(k) = 0.0d0
26392 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
26393 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
26394       END DO
26395
26396
26397 !c! Compute head-head and head-tail energies for each state
26398
26399         isel = iabs(Qi) + iabs(Qj)
26400 ! double charge for Phophorylated! itype - 25,27,27
26401 !          if ((itype(i).eq.27).or.(itype(i).eq.26).or.(itype(i).eq.25)) then
26402 !            Qi=Qi*2
26403 !            Qij=Qij*2
26404 !           endif
26405 !          if ((itype(j).eq.27).or.(itype(j).eq.26).or.(itype(j).eq.25)) then
26406 !            Qj=Qj*2
26407 !            Qij=Qij*2
26408 !           endif
26409
26410 !          isel=0
26411         IF (isel.eq.0) THEN
26412 !c! No charges - do nothing
26413          eheadtail = 0.0d0
26414
26415         ELSE IF (isel.eq.4) THEN
26416 !c! Calculate dipole-dipole interactions
26417          CALL edd(ecl)
26418          eheadtail = ECL
26419 !           eheadtail = 0.0d0
26420
26421         ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
26422 !c! Charge-nonpolar interactions
26423         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26424           Qi=Qi*2
26425           Qij=Qij*2
26426          endif
26427         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26428           Qj=Qj*2
26429           Qij=Qij*2
26430          endif
26431
26432          CALL eqn(epol)
26433          eheadtail = epol
26434 !           eheadtail = 0.0d0
26435
26436         ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
26437 !c! Nonpolar-charge interactions
26438         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26439           Qi=Qi*2
26440           Qij=Qij*2
26441          endif
26442         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26443           Qj=Qj*2
26444           Qij=Qij*2
26445          endif
26446
26447          CALL enq(epol)
26448          eheadtail = epol
26449 !           eheadtail = 0.0d0
26450
26451         ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
26452 !c! Charge-dipole interactions
26453         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26454           Qi=Qi*2
26455           Qij=Qij*2
26456          endif
26457         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26458           Qj=Qj*2
26459           Qij=Qij*2
26460          endif
26461
26462          CALL eqd(ecl, elj, epol)
26463          eheadtail = ECL + elj + epol
26464 !           eheadtail = 0.0d0
26465
26466         ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
26467 !c! Dipole-charge interactions
26468         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26469           Qi=Qi*2
26470           Qij=Qij*2
26471          endif
26472         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26473           Qj=Qj*2
26474           Qij=Qij*2
26475          endif
26476          CALL edq(ecl, elj, epol)
26477         eheadtail = ECL + elj + epol
26478 !           eheadtail = 0.0d0
26479
26480         ELSE IF ((isel.eq.2.and.   &
26481              iabs(Qi).eq.1).and.  &
26482              nstate(itypi,itypj).eq.1) THEN
26483 !c! Same charge-charge interaction ( +/+ or -/- )
26484         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26485           Qi=Qi*2
26486           Qij=Qij*2
26487          endif
26488         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26489           Qj=Qj*2
26490           Qij=Qij*2
26491          endif
26492
26493          CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
26494          eheadtail = ECL + Egb + Epol + Fisocav + Elj
26495 !           eheadtail = 0.0d0
26496
26497         ELSE IF ((isel.eq.2.and.  &
26498              iabs(Qi).eq.1).and. &
26499              nstate(itypi,itypj).ne.1) THEN
26500 !c! Different charge-charge interaction ( +/- or -/+ )
26501         if ((itype(i,1).eq.27).or.(itype(i,1).eq.26).or.(itype(i,1).eq.25)) then
26502           Qi=Qi*2
26503           Qij=Qij*2
26504          endif
26505         if ((itype(j,1).eq.27).or.(itype(j,1).eq.26).or.(itype(j,1).eq.25)) then
26506           Qj=Qj*2
26507           Qij=Qij*2
26508          endif
26509
26510          CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
26511         END IF
26512        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
26513       evdw = evdw  + Fcav + eheadtail
26514
26515        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
26516       restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
26517       1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
26518       Equad,evdwij+Fcav+eheadtail,evdw
26519 !       evdw = evdw  + Fcav  + eheadtail
26520
26521       iF (nstate(itypi,itypj).eq.1) THEN
26522       CALL sc_grad
26523        END IF
26524 !c!-------------------------------------------------------------------
26525 !c! NAPISY KONCOWE
26526        END DO   ! j
26527       END DO    ! iint
26528        END DO     ! i
26529 !c      write (iout,*) "Number of loop steps in EGB:",ind
26530 !c      energy_dec=.false.
26531 !              print *,"EVDW KURW",evdw,nres
26532
26533        RETURN
26534       END SUBROUTINE emomo
26535 !C------------------------------------------------------------------------------------
26536       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
26537       use calc_data
26538       use comm_momo
26539        real (kind=8) ::  facd3, facd4, federmaus, adler,&
26540        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
26541 !       integer :: k
26542 !c! Epol and Gpol analytical parameters
26543        alphapol1 = alphapol(itypi,itypj)
26544        alphapol2 = alphapol(itypj,itypi)
26545 !c! Fisocav and Gisocav analytical parameters
26546        al1  = alphiso(1,itypi,itypj)
26547        al2  = alphiso(2,itypi,itypj)
26548        al3  = alphiso(3,itypi,itypj)
26549        al4  = alphiso(4,itypi,itypj)
26550        csig = (1.0d0  &
26551          / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
26552          + sigiso2(itypi,itypj)**2.0d0))
26553 !c!
26554        pis  = sig0head(itypi,itypj)
26555        eps_head = epshead(itypi,itypj)
26556        Rhead_sq = Rhead * Rhead
26557 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26558 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26559        R1 = 0.0d0
26560        R2 = 0.0d0
26561        DO k = 1, 3
26562 !c! Calculate head-to-tail distances needed by Epol
26563       R1=R1+(ctail(k,2)-chead(k,1))**2
26564       R2=R2+(chead(k,2)-ctail(k,1))**2
26565        END DO
26566 !c! Pitagoras
26567        R1 = dsqrt(R1)
26568        R2 = dsqrt(R2)
26569
26570 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26571 !c!     &        +dhead(1,1,itypi,itypj))**2))
26572 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26573 !c!     &        +dhead(2,1,itypi,itypj))**2))
26574
26575 !c!-------------------------------------------------------------------
26576 !c! Coulomb electrostatic interaction
26577        Ecl = (332.0d0 * Qij) / Rhead
26578 !c! derivative of Ecl is Gcl...
26579        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
26580        dGCLdOM1 = 0.0d0
26581        dGCLdOM2 = 0.0d0
26582        dGCLdOM12 = 0.0d0
26583        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26584        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26585        debkap=debaykap(itypi,itypj)
26586        Egb = -(332.0d0 * Qij *&
26587       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
26588 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
26589 !c! Derivative of Egb is Ggb...
26590        dGGBdFGB = -(-332.0d0 * Qij * &
26591        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
26592        -(332.0d0 * Qij *&
26593       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
26594        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
26595        dGGBdR = dGGBdFGB * dFGBdR
26596 !c!-------------------------------------------------------------------
26597 !c! Fisocav - isotropic cavity creation term
26598 !c! or "how much energy it costs to put charged head in water"
26599        pom = Rhead * csig
26600        top = al1 * (dsqrt(pom) + al2 * pom - al3)
26601        bot = (1.0d0 + al4 * pom**12.0d0)
26602        botsq = bot * bot
26603        FisoCav = top / bot
26604 !      write (*,*) "Rhead = ",Rhead
26605 !      write (*,*) "csig = ",csig
26606 !      write (*,*) "pom = ",pom
26607 !      write (*,*) "al1 = ",al1
26608 !      write (*,*) "al2 = ",al2
26609 !      write (*,*) "al3 = ",al3
26610 !      write (*,*) "al4 = ",al4
26611 !        write (*,*) "top = ",top
26612 !        write (*,*) "bot = ",bot
26613 !c! Derivative of Fisocav is GCV...
26614        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26615        dbot = 12.0d0 * al4 * pom ** 11.0d0
26616        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26617 !c!-------------------------------------------------------------------
26618 !c! Epol
26619 !c! Polarization energy - charged heads polarize hydrophobic "neck"
26620        MomoFac1 = (1.0d0 - chi1 * sqom2)
26621        MomoFac2 = (1.0d0 - chi2 * sqom1)
26622        RR1  = ( R1 * R1 ) / MomoFac1
26623        RR2  = ( R2 * R2 ) / MomoFac2
26624        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26625        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26626        fgb1 = sqrt( RR1 + a12sq * ee1 )
26627        fgb2 = sqrt( RR2 + a12sq * ee2 )
26628        epol = 332.0d0 * eps_inout_fac * ( &
26629       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26630 !c!       epol = 0.0d0
26631        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26632              / (fgb1 ** 5.0d0)
26633        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26634              / (fgb2 ** 5.0d0)
26635        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
26636            / ( 2.0d0 * fgb1 )
26637        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
26638            / ( 2.0d0 * fgb2 )
26639        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
26640             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
26641        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
26642             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
26643        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26644 !c!       dPOLdR1 = 0.0d0
26645        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26646 !c!       dPOLdR2 = 0.0d0
26647        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26648 !c!       dPOLdOM1 = 0.0d0
26649        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26650 !c!       dPOLdOM2 = 0.0d0
26651 !c!-------------------------------------------------------------------
26652 !c! Elj
26653 !c! Lennard-Jones 6-12 interaction between heads
26654        pom = (pis / Rhead)**6.0d0
26655        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26656 !c! derivative of Elj is Glj
26657        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
26658            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26659 !c!-------------------------------------------------------------------
26660 !c! Return the results
26661 !c! These things do the dRdX derivatives, that is
26662 !c! allow us to change what we see from function that changes with
26663 !c! distance to function that changes with LOCATION (of the interaction
26664 !c! site)
26665        DO k = 1, 3
26666       erhead(k) = Rhead_distance(k)/Rhead
26667       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26668       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26669        END DO
26670
26671        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26672        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
26673        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26674        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
26675        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
26676        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26677        facd1 = d1 * vbld_inv(i+nres)
26678        facd2 = d2 * vbld_inv(j+nres)
26679        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
26680        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
26681
26682 !c! Now we add appropriate partial derivatives (one in each dimension)
26683        DO k = 1, 3
26684       hawk   = (erhead_tail(k,1) + &
26685       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
26686       condor = (erhead_tail(k,2) + &
26687       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
26688
26689       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26690       gvdwx(k,i) = gvdwx(k,i) &
26691               - dGCLdR * pom&
26692               - dGGBdR * pom&
26693               - dGCVdR * pom&
26694               - dPOLdR1 * hawk&
26695               - dPOLdR2 * (erhead_tail(k,2)&
26696       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26697               - dGLJdR * pom
26698
26699       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
26700       gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
26701                + dGGBdR * pom+ dGCVdR * pom&
26702               + dPOLdR1 * (erhead_tail(k,1)&
26703       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
26704               + dPOLdR2 * condor + dGLJdR * pom
26705
26706       gvdwc(k,i) = gvdwc(k,i)  &
26707               - dGCLdR * erhead(k)&
26708               - dGGBdR * erhead(k)&
26709               - dGCVdR * erhead(k)&
26710               - dPOLdR1 * erhead_tail(k,1)&
26711               - dPOLdR2 * erhead_tail(k,2)&
26712               - dGLJdR * erhead(k)
26713
26714       gvdwc(k,j) = gvdwc(k,j)         &
26715               + dGCLdR * erhead(k) &
26716               + dGGBdR * erhead(k) &
26717               + dGCVdR * erhead(k) &
26718               + dPOLdR1 * erhead_tail(k,1) &
26719               + dPOLdR2 * erhead_tail(k,2)&
26720               + dGLJdR * erhead(k)
26721
26722        END DO
26723        RETURN
26724       END SUBROUTINE eqq
26725
26726       SUBROUTINE eqq_cat(Ecl,Egb,Epol,Fisocav,Elj)
26727       use calc_data
26728       use comm_momo
26729        real (kind=8) ::  facd3, facd4, federmaus, adler,&
26730        Ecl,Egb,Epol,Fisocav,Elj,Fgb,debkap
26731 !       integer :: k
26732 !c! Epol and Gpol analytical parameters
26733        alphapol1 = alphapolcat(itypi,itypj)
26734        alphapol2 = alphapolcat2(itypj,itypi)
26735 !c! Fisocav and Gisocav analytical parameters
26736        al1  = alphisocat(1,itypi,itypj)
26737        al2  = alphisocat(2,itypi,itypj)
26738        al3  = alphisocat(3,itypi,itypj)
26739        al4  = alphisocat(4,itypi,itypj)
26740        csig = (1.0d0  &
26741          / dsqrt(sigiso1cat(itypi, itypj)**2.0d0 &
26742          + sigiso2cat(itypi,itypj)**2.0d0))
26743 !c!
26744        pis  = sig0headcat(itypi,itypj)
26745        eps_head = epsheadcat(itypi,itypj)
26746        Rhead_sq = Rhead * Rhead
26747 !c! R1 - distance between head of ith side chain and tail of jth sidechain
26748 !c! R2 - distance between head of jth side chain and tail of ith sidechain
26749        R1 = 0.0d0
26750        R2 = 0.0d0
26751        DO k = 1, 3
26752 !c! Calculate head-to-tail distances needed by Epol
26753       R1=R1+(ctail(k,2)-chead(k,1))**2
26754       R2=R2+(chead(k,2)-ctail(k,1))**2
26755        END DO
26756 !c! Pitagoras
26757        R1 = dsqrt(R1)
26758        R2 = dsqrt(R2)
26759
26760 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
26761 !c!     &        +dhead(1,1,itypi,itypj))**2))
26762 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
26763 !c!     &        +dhead(2,1,itypi,itypj))**2))
26764
26765 !c!-------------------------------------------------------------------
26766 !c! Coulomb electrostatic interaction
26767        Ecl = (332.0d0 * Qij) / Rhead
26768 !c! derivative of Ecl is Gcl...
26769        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
26770        dGCLdOM1 = 0.0d0
26771        dGCLdOM2 = 0.0d0
26772        dGCLdOM12 = 0.0d0
26773        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
26774        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
26775        debkap=debaykapcat(itypi,itypj)
26776        Egb = -(332.0d0 * Qij *&
26777       (1.0/eps_in-dexp(-debkap*Fgb)/eps_out)) / Fgb
26778 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
26779 !c! Derivative of Egb is Ggb...
26780        dGGBdFGB = -(-332.0d0 * Qij * &
26781        (1.0/eps_in-dexp(-debkap*Fgb)/eps_out))/(Fgb*Fgb)&
26782        -(332.0d0 * Qij *&
26783       (dexp(-debkap*Fgb)*debkap/eps_out))/ Fgb
26784        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
26785        dGGBdR = dGGBdFGB * dFGBdR
26786 !c!-------------------------------------------------------------------
26787 !c! Fisocav - isotropic cavity creation term
26788 !c! or "how much energy it costs to put charged head in water"
26789        pom = Rhead * csig
26790        top = al1 * (dsqrt(pom) + al2 * pom - al3)
26791        bot = (1.0d0 + al4 * pom**12.0d0)
26792        botsq = bot * bot
26793        FisoCav = top / bot
26794 !      write (*,*) "Rhead = ",Rhead
26795 !      write (*,*) "csig = ",csig
26796 !      write (*,*) "pom = ",pom
26797 !      write (*,*) "al1 = ",al1
26798 !      write (*,*) "al2 = ",al2
26799 !      write (*,*) "al3 = ",al3
26800 !      write (*,*) "al4 = ",al4
26801 !        write (*,*) "top = ",top
26802 !        write (*,*) "bot = ",bot
26803 !c! Derivative of Fisocav is GCV...
26804        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
26805        dbot = 12.0d0 * al4 * pom ** 11.0d0
26806        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
26807 !c!-------------------------------------------------------------------
26808 !c! Epol
26809 !c! Polarization energy - charged heads polarize hydrophobic "neck"
26810        MomoFac1 = (1.0d0 - chi1 * sqom2)
26811        MomoFac2 = (1.0d0 - chi2 * sqom1)
26812        RR1  = ( R1 * R1 ) / MomoFac1
26813        RR2  = ( R2 * R2 ) / MomoFac2
26814        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
26815        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
26816        fgb1 = sqrt( RR1 + a12sq * ee1 )
26817        fgb2 = sqrt( RR2 + a12sq * ee2 )
26818        epol = 332.0d0 * eps_inout_fac * ( &
26819       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
26820 !c!       epol = 0.0d0
26821        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
26822              / (fgb1 ** 5.0d0)
26823        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
26824              / (fgb2 ** 5.0d0)
26825        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
26826            / ( 2.0d0 * fgb1 )
26827        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
26828            / ( 2.0d0 * fgb2 )
26829        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
26830             * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
26831        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
26832             * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
26833        dPOLdR1 = dPOLdFGB1 * dFGBdR1
26834 !c!       dPOLdR1 = 0.0d0
26835        dPOLdR2 = dPOLdFGB2 * dFGBdR2
26836 !c!       dPOLdR2 = 0.0d0
26837        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
26838 !c!       dPOLdOM1 = 0.0d0
26839        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
26840 !c!       dPOLdOM2 = 0.0d0
26841 !c!-------------------------------------------------------------------
26842 !c! Elj
26843 !c! Lennard-Jones 6-12 interaction between heads
26844        pom = (pis / Rhead)**6.0d0
26845        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
26846 !c! derivative of Elj is Glj
26847        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
26848            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
26849 !c!-------------------------------------------------------------------
26850 !c! Return the results
26851 !c! These things do the dRdX derivatives, that is
26852 !c! allow us to change what we see from function that changes with
26853 !c! distance to function that changes with LOCATION (of the interaction
26854 !c! site)
26855        DO k = 1, 3
26856       erhead(k) = Rhead_distance(k)/Rhead
26857       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
26858       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
26859        END DO
26860
26861        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
26862        erdxj = scalar( erhead(1), dC_norm(1,j) )
26863        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
26864        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
26865        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
26866        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
26867        facd1 = d1 * vbld_inv(i+nres)
26868        facd2 = d2 * vbld_inv(j)
26869        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
26870        facd4 = dtailcat(2,itypi,itypj) * vbld_inv(j)
26871
26872 !c! Now we add appropriate partial derivatives (one in each dimension)
26873        DO k = 1, 3
26874       hawk   = (erhead_tail(k,1) + &
26875       facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
26876       condor = (erhead_tail(k,2) + &
26877       facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
26878
26879       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
26880       gradpepcatx(k,i) = gradpepcatx(k,i) &
26881               - dGCLdR * pom&
26882               - dGGBdR * pom&
26883               - dGCVdR * pom&
26884               - dPOLdR1 * hawk&
26885               - dPOLdR2 * (erhead_tail(k,2)&
26886       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
26887               - dGLJdR * pom
26888
26889       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
26890 !        gradpepcatx(k,j) = gradpepcatx(k,j)+ dGCLdR * pom&
26891 !                   + dGGBdR * pom+ dGCVdR * pom&
26892 !                  + dPOLdR1 * (erhead_tail(k,1)&
26893 !      -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j)))&
26894 !                  + dPOLdR2 * condor + dGLJdR * pom
26895
26896       gradpepcat(k,i) = gradpepcat(k,i)  &
26897               - dGCLdR * erhead(k)&
26898               - dGGBdR * erhead(k)&
26899               - dGCVdR * erhead(k)&
26900               - dPOLdR1 * erhead_tail(k,1)&
26901               - dPOLdR2 * erhead_tail(k,2)&
26902               - dGLJdR * erhead(k)
26903
26904       gradpepcat(k,j) = gradpepcat(k,j)         &
26905               + dGCLdR * erhead(k) &
26906               + dGGBdR * erhead(k) &
26907               + dGCVdR * erhead(k) &
26908               + dPOLdR1 * erhead_tail(k,1) &
26909               + dPOLdR2 * erhead_tail(k,2)&
26910               + dGLJdR * erhead(k)
26911
26912        END DO
26913        RETURN
26914       END SUBROUTINE eqq_cat
26915 !c!-------------------------------------------------------------------
26916       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
26917       use comm_momo
26918       use calc_data
26919
26920        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
26921        double precision ener(4)
26922        double precision dcosom1(3),dcosom2(3)
26923 !c! used in Epol derivatives
26924        double precision facd3, facd4
26925        double precision federmaus, adler
26926        integer istate,ii,jj
26927        real (kind=8) :: Fgb
26928 !       print *,"CALLING EQUAD"
26929 !c! Epol and Gpol analytical parameters
26930        alphapol1 = alphapol(itypi,itypj)
26931        alphapol2 = alphapol(itypj,itypi)
26932 !c! Fisocav and Gisocav analytical parameters
26933        al1  = alphiso(1,itypi,itypj)
26934        al2  = alphiso(2,itypi,itypj)
26935        al3  = alphiso(3,itypi,itypj)
26936        al4  = alphiso(4,itypi,itypj)
26937        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
26938           + sigiso2(itypi,itypj)**2.0d0))
26939 !c!
26940        w1   = wqdip(1,itypi,itypj)
26941        w2   = wqdip(2,itypi,itypj)
26942        pis  = sig0head(itypi,itypj)
26943        eps_head = epshead(itypi,itypj)
26944 !c! First things first:
26945 !c! We need to do sc_grad's job with GB and Fcav
26946        eom1  = eps2der * eps2rt_om1 &
26947            - 2.0D0 * alf1 * eps3der&
26948            + sigder * sigsq_om1&
26949            + dCAVdOM1
26950        eom2  = eps2der * eps2rt_om2 &
26951            + 2.0D0 * alf2 * eps3der&
26952            + sigder * sigsq_om2&
26953            + dCAVdOM2
26954        eom12 =  evdwij  * eps1_om12 &
26955            + eps2der * eps2rt_om12 &
26956            - 2.0D0 * alf12 * eps3der&
26957            + sigder *sigsq_om12&
26958            + dCAVdOM12
26959 !c! now some magical transformations to project gradient into
26960 !c! three cartesian vectors
26961        DO k = 1, 3
26962       dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
26963       dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
26964       gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
26965 !c! this acts on hydrophobic center of interaction
26966       gvdwx(k,i)= gvdwx(k,i) - gg(k) &
26967               + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
26968               + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
26969       gvdwx(k,j)= gvdwx(k,j) + gg(k) &
26970               + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
26971               + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
26972 !c! this acts on Calpha
26973       gvdwc(k,i)=gvdwc(k,i)-gg(k)
26974       gvdwc(k,j)=gvdwc(k,j)+gg(k)
26975        END DO
26976 !c! sc_grad is done, now we will compute
26977        eheadtail = 0.0d0
26978        eom1 = 0.0d0
26979        eom2 = 0.0d0
26980        eom12 = 0.0d0
26981        DO istate = 1, nstate(itypi,itypj)
26982 !c*************************************************************
26983       IF (istate.ne.1) THEN
26984        IF (istate.lt.3) THEN
26985         ii = 1
26986        ELSE
26987         ii = 2
26988        END IF
26989       jj = istate/ii
26990       d1 = dhead(1,ii,itypi,itypj)
26991       d2 = dhead(2,jj,itypi,itypj)
26992       DO k = 1,3
26993        chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
26994        chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
26995        Rhead_distance(k) = chead(k,2) - chead(k,1)
26996       END DO
26997 !c! pitagoras (root of sum of squares)
26998       Rhead = dsqrt( &
26999              (Rhead_distance(1)*Rhead_distance(1))  &
27000            + (Rhead_distance(2)*Rhead_distance(2))  &
27001            + (Rhead_distance(3)*Rhead_distance(3)))
27002       END IF
27003       Rhead_sq = Rhead * Rhead
27004
27005 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27006 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27007       R1 = 0.0d0
27008       R2 = 0.0d0
27009       DO k = 1, 3
27010 !c! Calculate head-to-tail distances
27011        R1=R1+(ctail(k,2)-chead(k,1))**2
27012        R2=R2+(chead(k,2)-ctail(k,1))**2
27013       END DO
27014 !c! Pitagoras
27015       R1 = dsqrt(R1)
27016       R2 = dsqrt(R2)
27017       Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
27018 !c!        Ecl = 0.0d0
27019 !c!        write (*,*) "Ecl = ", Ecl
27020 !c! derivative of Ecl is Gcl...
27021       dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
27022 !c!        dGCLdR = 0.0d0
27023       dGCLdOM1 = 0.0d0
27024       dGCLdOM2 = 0.0d0
27025       dGCLdOM12 = 0.0d0
27026 !c!-------------------------------------------------------------------
27027 !c! Generalised Born Solvent Polarization
27028       ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
27029       Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
27030       Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
27031 !c!        Egb = 0.0d0
27032 !c!      write (*,*) "a1*a2 = ", a12sq
27033 !c!      write (*,*) "Rhead = ", Rhead
27034 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
27035 !c!      write (*,*) "ee = ", ee
27036 !c!      write (*,*) "Fgb = ", Fgb
27037 !c!      write (*,*) "fac = ", eps_inout_fac
27038 !c!      write (*,*) "Qij = ", Qij
27039 !c!      write (*,*) "Egb = ", Egb
27040 !c! Derivative of Egb is Ggb...
27041 !c! dFGBdR is used by Quad's later...
27042       dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
27043       dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
27044              / ( 2.0d0 * Fgb )
27045       dGGBdR = dGGBdFGB * dFGBdR
27046 !c!        dGGBdR = 0.0d0
27047 !c!-------------------------------------------------------------------
27048 !c! Fisocav - isotropic cavity creation term
27049       pom = Rhead * csig
27050       top = al1 * (dsqrt(pom) + al2 * pom - al3)
27051       bot = (1.0d0 + al4 * pom**12.0d0)
27052       botsq = bot * bot
27053       FisoCav = top / bot
27054       dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
27055       dbot = 12.0d0 * al4 * pom ** 11.0d0
27056       dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
27057 !c!        dGCVdR = 0.0d0
27058 !c!-------------------------------------------------------------------
27059 !c! Polarization energy
27060 !c! Epol
27061       MomoFac1 = (1.0d0 - chi1 * sqom2)
27062       MomoFac2 = (1.0d0 - chi2 * sqom1)
27063       RR1  = ( R1 * R1 ) / MomoFac1
27064       RR2  = ( R2 * R2 ) / MomoFac2
27065       ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27066       ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
27067       fgb1 = sqrt( RR1 + a12sq * ee1 )
27068       fgb2 = sqrt( RR2 + a12sq * ee2 )
27069       epol = 332.0d0 * eps_inout_fac * (&
27070       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
27071 !c!        epol = 0.0d0
27072 !c! derivative of Epol is Gpol...
27073       dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
27074               / (fgb1 ** 5.0d0)
27075       dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
27076               / (fgb2 ** 5.0d0)
27077       dFGBdR1 = ( (R1 / MomoFac1) &
27078             * ( 2.0d0 - (0.5d0 * ee1) ) )&
27079             / ( 2.0d0 * fgb1 )
27080       dFGBdR2 = ( (R2 / MomoFac2) &
27081             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27082             / ( 2.0d0 * fgb2 )
27083       dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
27084              * ( 2.0d0 - 0.5d0 * ee1) ) &
27085              / ( 2.0d0 * fgb1 )
27086       dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27087              * ( 2.0d0 - 0.5d0 * ee2) ) &
27088              / ( 2.0d0 * fgb2 )
27089       dPOLdR1 = dPOLdFGB1 * dFGBdR1
27090 !c!        dPOLdR1 = 0.0d0
27091       dPOLdR2 = dPOLdFGB2 * dFGBdR2
27092 !c!        dPOLdR2 = 0.0d0
27093       dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27094 !c!        dPOLdOM1 = 0.0d0
27095       dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27096       pom = (pis / Rhead)**6.0d0
27097       Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27098 !c!        Elj = 0.0d0
27099 !c! derivative of Elj is Glj
27100       dGLJdR = 4.0d0 * eps_head &
27101           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27102           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27103 !c!        dGLJdR = 0.0d0
27104 !c!-------------------------------------------------------------------
27105 !c! Equad
27106        IF (Wqd.ne.0.0d0) THEN
27107       Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
27108            - 37.5d0  * ( sqom1 + sqom2 ) &
27109            + 157.5d0 * ( sqom1 * sqom2 ) &
27110            - 45.0d0  * om1*om2*om12
27111       fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
27112       Equad = fac * Beta1
27113 !c!        Equad = 0.0d0
27114 !c! derivative of Equad...
27115       dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
27116 !c!        dQUADdR = 0.0d0
27117       dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
27118 !c!        dQUADdOM1 = 0.0d0
27119       dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
27120 !c!        dQUADdOM2 = 0.0d0
27121       dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
27122        ELSE
27123        Beta1 = 0.0d0
27124        Equad = 0.0d0
27125       END IF
27126 !c!-------------------------------------------------------------------
27127 !c! Return the results
27128 !c! Angular stuff
27129       eom1 = dPOLdOM1 + dQUADdOM1
27130       eom2 = dPOLdOM2 + dQUADdOM2
27131       eom12 = dQUADdOM12
27132 !c! now some magical transformations to project gradient into
27133 !c! three cartesian vectors
27134       DO k = 1, 3
27135        dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
27136        dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
27137        tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
27138       END DO
27139 !c! Radial stuff
27140       DO k = 1, 3
27141        erhead(k) = Rhead_distance(k)/Rhead
27142        erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27143        erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27144       END DO
27145       erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27146       erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27147       bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27148       federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27149       eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27150       adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27151       facd1 = d1 * vbld_inv(i+nres)
27152       facd2 = d2 * vbld_inv(j+nres)
27153       facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27154       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27155       DO k = 1, 3
27156        hawk   = erhead_tail(k,1) + &
27157        facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
27158        condor = erhead_tail(k,2) + &
27159        facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
27160
27161        pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27162 !c! this acts on hydrophobic center of interaction
27163        gheadtail(k,1,1) = gheadtail(k,1,1) &
27164                    - dGCLdR * pom &
27165                    - dGGBdR * pom &
27166                    - dGCVdR * pom &
27167                    - dPOLdR1 * hawk &
27168                    - dPOLdR2 * (erhead_tail(k,2) &
27169       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
27170                    - dGLJdR * pom &
27171                    - dQUADdR * pom&
27172                    - tuna(k) &
27173              + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
27174              + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
27175
27176        pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27177 !c! this acts on hydrophobic center of interaction
27178        gheadtail(k,2,1) = gheadtail(k,2,1)  &
27179                    + dGCLdR * pom      &
27180                    + dGGBdR * pom      &
27181                    + dGCVdR * pom      &
27182                    + dPOLdR1 * (erhead_tail(k,1) &
27183       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
27184                    + dPOLdR2 * condor &
27185                    + dGLJdR * pom &
27186                    + dQUADdR * pom &
27187                    + tuna(k) &
27188              + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
27189              + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
27190
27191 !c! this acts on Calpha
27192        gheadtail(k,3,1) = gheadtail(k,3,1)  &
27193                    - dGCLdR * erhead(k)&
27194                    - dGGBdR * erhead(k)&
27195                    - dGCVdR * erhead(k)&
27196                    - dPOLdR1 * erhead_tail(k,1)&
27197                    - dPOLdR2 * erhead_tail(k,2)&
27198                    - dGLJdR * erhead(k) &
27199                    - dQUADdR * erhead(k)&
27200                    - tuna(k)
27201 !c! this acts on Calpha
27202        gheadtail(k,4,1) = gheadtail(k,4,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       END DO
27212       ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
27213       eheadtail = eheadtail &
27214               + wstate(istate, itypi, itypj) &
27215               * dexp(-betaT * ener(istate))
27216 !c! foreach cartesian dimension
27217       DO k = 1, 3
27218 !c! foreach of two gvdwx and gvdwc
27219        DO l = 1, 4
27220         gheadtail(k,l,2) = gheadtail(k,l,2)  &
27221                      + wstate( istate, itypi, itypj ) &
27222                      * dexp(-betaT * ener(istate)) &
27223                      * gheadtail(k,l,1)
27224         gheadtail(k,l,1) = 0.0d0
27225        END DO
27226       END DO
27227        END DO
27228 !c! Here ended the gigantic DO istate = 1, 4, which starts
27229 !c! at the beggining of the subroutine
27230
27231        DO k = 1, 3
27232       DO l = 1, 4
27233        gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
27234       END DO
27235       gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
27236       gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
27237       gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
27238       gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
27239       DO l = 1, 4
27240        gheadtail(k,l,1) = 0.0d0
27241        gheadtail(k,l,2) = 0.0d0
27242       END DO
27243        END DO
27244        eheadtail = (-dlog(eheadtail)) / betaT
27245        dPOLdOM1 = 0.0d0
27246        dPOLdOM2 = 0.0d0
27247        dQUADdOM1 = 0.0d0
27248        dQUADdOM2 = 0.0d0
27249        dQUADdOM12 = 0.0d0
27250        RETURN
27251       END SUBROUTINE energy_quad
27252 !!-----------------------------------------------------------
27253       SUBROUTINE eqn(Epol)
27254       use comm_momo
27255       use calc_data
27256
27257       double precision  facd4, federmaus,epol
27258       alphapol1 = alphapol(itypi,itypj)
27259 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27260        R1 = 0.0d0
27261        DO k = 1, 3
27262 !c! Calculate head-to-tail distances
27263       R1=R1+(ctail(k,2)-chead(k,1))**2
27264        END DO
27265 !c! Pitagoras
27266        R1 = dsqrt(R1)
27267
27268 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27269 !c!     &        +dhead(1,1,itypi,itypj))**2))
27270 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27271 !c!     &        +dhead(2,1,itypi,itypj))**2))
27272 !c--------------------------------------------------------------------
27273 !c Polarization energy
27274 !c Epol
27275        MomoFac1 = (1.0d0 - chi1 * sqom2)
27276        RR1  = R1 * R1 / MomoFac1
27277        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27278        fgb1 = sqrt( RR1 + a12sq * ee1)
27279        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
27280        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
27281              / (fgb1 ** 5.0d0)
27282        dFGBdR1 = ( (R1 / MomoFac1) &
27283             * ( 2.0d0 - (0.5d0 * ee1) ) ) &
27284             / ( 2.0d0 * fgb1 )
27285        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
27286             * (2.0d0 - 0.5d0 * ee1) ) &
27287             / (2.0d0 * fgb1)
27288        dPOLdR1 = dPOLdFGB1 * dFGBdR1
27289 !c!       dPOLdR1 = 0.0d0
27290        dPOLdOM1 = 0.0d0
27291        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27292        DO k = 1, 3
27293       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27294        END DO
27295        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27296        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27297        facd1 = d1 * vbld_inv(i+nres)
27298        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27299
27300        DO k = 1, 3
27301       hawk = (erhead_tail(k,1) + &
27302       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
27303
27304       gvdwx(k,i) = gvdwx(k,i) &
27305                - dPOLdR1 * hawk
27306       gvdwx(k,j) = gvdwx(k,j) &
27307                + dPOLdR1 * (erhead_tail(k,1) &
27308        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
27309
27310       gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
27311       gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
27312
27313        END DO
27314        RETURN
27315       END SUBROUTINE eqn
27316       SUBROUTINE enq(Epol)
27317       use calc_data
27318       use comm_momo
27319        double precision facd3, adler,epol
27320        alphapol2 = alphapol(itypj,itypi)
27321 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27322        R2 = 0.0d0
27323        DO k = 1, 3
27324 !c! Calculate head-to-tail distances
27325       R2=R2+(chead(k,2)-ctail(k,1))**2
27326        END DO
27327 !c! Pitagoras
27328        R2 = dsqrt(R2)
27329
27330 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27331 !c!     &        +dhead(1,1,itypi,itypj))**2))
27332 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27333 !c!     &        +dhead(2,1,itypi,itypj))**2))
27334 !c------------------------------------------------------------------------
27335 !c Polarization energy
27336        MomoFac2 = (1.0d0 - chi2 * sqom1)
27337        RR2  = R2 * R2 / MomoFac2
27338        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27339        fgb2 = sqrt(RR2  + a12sq * ee2)
27340        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27341        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27342             / (fgb2 ** 5.0d0)
27343        dFGBdR2 = ( (R2 / MomoFac2)  &
27344             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27345             / (2.0d0 * fgb2)
27346        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27347             * (2.0d0 - 0.5d0 * ee2) ) &
27348             / (2.0d0 * fgb2)
27349        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27350 !c!       dPOLdR2 = 0.0d0
27351        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27352 !c!       dPOLdOM1 = 0.0d0
27353        dPOLdOM2 = 0.0d0
27354 !c!-------------------------------------------------------------------
27355 !c! Return the results
27356 !c! (See comments in Eqq)
27357        DO k = 1, 3
27358       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27359        END DO
27360        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27361        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27362        facd2 = d2 * vbld_inv(j+nres)
27363        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27364        DO k = 1, 3
27365       condor = (erhead_tail(k,2) &
27366        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
27367
27368       gvdwx(k,i) = gvdwx(k,i) &
27369                - dPOLdR2 * (erhead_tail(k,2) &
27370        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
27371       gvdwx(k,j) = gvdwx(k,j)   &
27372                + dPOLdR2 * condor
27373
27374       gvdwc(k,i) = gvdwc(k,i) &
27375                - dPOLdR2 * erhead_tail(k,2)
27376       gvdwc(k,j) = gvdwc(k,j) &
27377                + dPOLdR2 * erhead_tail(k,2)
27378
27379        END DO
27380       RETURN
27381       END SUBROUTINE enq
27382
27383       SUBROUTINE enq_cat(Epol)
27384       use calc_data
27385       use comm_momo
27386        double precision facd3, adler,epol
27387        alphapol2 = alphapolcat(itypi,itypj)
27388 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27389        R2 = 0.0d0
27390        DO k = 1, 3
27391 !c! Calculate head-to-tail distances
27392       R2=R2+(chead(k,2)-ctail(k,1))**2
27393        END DO
27394 !c! Pitagoras
27395        R2 = dsqrt(R2)
27396
27397 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27398 !c!     &        +dhead(1,1,itypi,itypj))**2))
27399 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27400 !c!     &        +dhead(2,1,itypi,itypj))**2))
27401 !c------------------------------------------------------------------------
27402 !c Polarization energy
27403        MomoFac2 = (1.0d0 - chi2 * sqom1)
27404        RR2  = R2 * R2 / MomoFac2
27405        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27406        fgb2 = sqrt(RR2  + a12sq * ee2)
27407        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27408        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27409             / (fgb2 ** 5.0d0)
27410        dFGBdR2 = ( (R2 / MomoFac2)  &
27411             * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27412             / (2.0d0 * fgb2)
27413        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27414             * (2.0d0 - 0.5d0 * ee2) ) &
27415             / (2.0d0 * fgb2)
27416        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27417 !c!       dPOLdR2 = 0.0d0
27418        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27419 !c!       dPOLdOM1 = 0.0d0
27420        dPOLdOM2 = 0.0d0
27421
27422 !c!-------------------------------------------------------------------
27423 !c! Return the results
27424 !c! (See comments in Eqq)
27425        DO k = 1, 3
27426       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27427        END DO
27428        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27429        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27430        facd2 = d2 * vbld_inv(j+nres)
27431        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
27432        DO k = 1, 3
27433       condor = (erhead_tail(k,2) &
27434        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27435
27436       gradpepcatx(k,i) = gradpepcatx(k,i) &
27437                - dPOLdR2 * (erhead_tail(k,2) &
27438        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
27439 !        gradpepcatx(k,j) = gradpepcatx(k,j)   &
27440 !                   + dPOLdR2 * condor
27441
27442       gradpepcat(k,i) = gradpepcat(k,i) &
27443                - dPOLdR2 * erhead_tail(k,2)
27444       gradpepcat(k,j) = gradpepcat(k,j) &
27445                + dPOLdR2 * erhead_tail(k,2)
27446
27447        END DO
27448       RETURN
27449       END SUBROUTINE enq_cat
27450
27451       SUBROUTINE eqd(Ecl,Elj,Epol)
27452       use calc_data
27453       use comm_momo
27454        double precision  facd4, federmaus,ecl,elj,epol
27455        alphapol1 = alphapol(itypi,itypj)
27456        w1        = wqdip(1,itypi,itypj)
27457        w2        = wqdip(2,itypi,itypj)
27458        pis       = sig0head(itypi,itypj)
27459        eps_head   = epshead(itypi,itypj)
27460 !c!-------------------------------------------------------------------
27461 !c! R1 - distance between head of ith side chain and tail of jth sidechain
27462        R1 = 0.0d0
27463        DO k = 1, 3
27464 !c! Calculate head-to-tail distances
27465       R1=R1+(ctail(k,2)-chead(k,1))**2
27466        END DO
27467 !c! Pitagoras
27468        R1 = dsqrt(R1)
27469
27470 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27471 !c!     &        +dhead(1,1,itypi,itypj))**2))
27472 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27473 !c!     &        +dhead(2,1,itypi,itypj))**2))
27474
27475 !c!-------------------------------------------------------------------
27476 !c! ecl
27477        sparrow  = w1 * Qi * om1
27478        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
27479        Ecl = sparrow / Rhead**2.0d0 &
27480          - hawk    / Rhead**4.0d0
27481        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27482              + 4.0d0 * hawk    / Rhead**5.0d0
27483 !c! dF/dom1
27484        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
27485 !c! dF/dom2
27486        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
27487 !c--------------------------------------------------------------------
27488 !c Polarization energy
27489 !c Epol
27490        MomoFac1 = (1.0d0 - chi1 * sqom2)
27491        RR1  = R1 * R1 / MomoFac1
27492        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
27493        fgb1 = sqrt( RR1 + a12sq * ee1)
27494        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
27495 !c!       epol = 0.0d0
27496 !c!------------------------------------------------------------------
27497 !c! derivative of Epol is Gpol...
27498        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
27499              / (fgb1 ** 5.0d0)
27500        dFGBdR1 = ( (R1 / MomoFac1)  &
27501            * ( 2.0d0 - (0.5d0 * ee1) ) ) &
27502            / ( 2.0d0 * fgb1 )
27503        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
27504              * (2.0d0 - 0.5d0 * ee1) ) &
27505              / (2.0d0 * fgb1)
27506        dPOLdR1 = dPOLdFGB1 * dFGBdR1
27507 !c!       dPOLdR1 = 0.0d0
27508        dPOLdOM1 = 0.0d0
27509        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
27510 !c!       dPOLdOM2 = 0.0d0
27511 !c!-------------------------------------------------------------------
27512 !c! Elj
27513        pom = (pis / Rhead)**6.0d0
27514        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27515 !c! derivative of Elj is Glj
27516        dGLJdR = 4.0d0 * eps_head &
27517         * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27518         +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27519        DO k = 1, 3
27520       erhead(k) = Rhead_distance(k)/Rhead
27521       erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
27522        END DO
27523
27524        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27525        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27526        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
27527        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
27528        facd1 = d1 * vbld_inv(i+nres)
27529        facd2 = d2 * vbld_inv(j+nres)
27530        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
27531
27532        DO k = 1, 3
27533       hawk = (erhead_tail(k,1) +  &
27534       facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
27535
27536       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27537       gvdwx(k,i) = gvdwx(k,i)  &
27538                - dGCLdR * pom&
27539                - dPOLdR1 * hawk &
27540                - dGLJdR * pom
27541
27542       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27543       gvdwx(k,j) = gvdwx(k,j)    &
27544                + dGCLdR * pom  &
27545                + dPOLdR1 * (erhead_tail(k,1) &
27546        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
27547                + dGLJdR * pom
27548
27549
27550       gvdwc(k,i) = gvdwc(k,i)          &
27551                - dGCLdR * erhead(k)  &
27552                - dPOLdR1 * erhead_tail(k,1) &
27553                - dGLJdR * erhead(k)
27554
27555       gvdwc(k,j) = gvdwc(k,j)          &
27556                + dGCLdR * erhead(k)  &
27557                + dPOLdR1 * erhead_tail(k,1) &
27558                + dGLJdR * erhead(k)
27559
27560        END DO
27561        RETURN
27562       END SUBROUTINE eqd
27563       SUBROUTINE edq(Ecl,Elj,Epol)
27564 !       IMPLICIT NONE
27565        use comm_momo
27566       use calc_data
27567
27568       double precision  facd3, adler,ecl,elj,epol
27569        alphapol2 = alphapol(itypj,itypi)
27570        w1        = wqdip(1,itypi,itypj)
27571        w2        = wqdip(2,itypi,itypj)
27572        pis       = sig0head(itypi,itypj)
27573        eps_head  = epshead(itypi,itypj)
27574 !c!-------------------------------------------------------------------
27575 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27576        R2 = 0.0d0
27577        DO k = 1, 3
27578 !c! Calculate head-to-tail distances
27579       R2=R2+(chead(k,2)-ctail(k,1))**2
27580        END DO
27581 !c! Pitagoras
27582        R2 = dsqrt(R2)
27583
27584 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27585 !c!     &        +dhead(1,1,itypi,itypj))**2))
27586 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27587 !c!     &        +dhead(2,1,itypi,itypj))**2))
27588
27589
27590 !c!-------------------------------------------------------------------
27591 !c! ecl
27592        sparrow  = w1 * Qj * om1
27593        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27594        ECL = sparrow / Rhead**2.0d0 &
27595          - hawk    / Rhead**4.0d0
27596 !c!-------------------------------------------------------------------
27597 !c! derivative of ecl is Gcl
27598 !c! dF/dr part
27599        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27600              + 4.0d0 * hawk    / Rhead**5.0d0
27601 !c! dF/dom1
27602        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27603 !c! dF/dom2
27604        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27605 !c--------------------------------------------------------------------
27606 !c Polarization energy
27607 !c Epol
27608        MomoFac2 = (1.0d0 - chi2 * sqom1)
27609        RR2  = R2 * R2 / MomoFac2
27610        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27611        fgb2 = sqrt(RR2  + a12sq * ee2)
27612        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27613        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27614              / (fgb2 ** 5.0d0)
27615        dFGBdR2 = ( (R2 / MomoFac2)  &
27616              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27617              / (2.0d0 * fgb2)
27618        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27619             * (2.0d0 - 0.5d0 * ee2) ) &
27620             / (2.0d0 * fgb2)
27621        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27622 !c!       dPOLdR2 = 0.0d0
27623        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27624 !c!       dPOLdOM1 = 0.0d0
27625        dPOLdOM2 = 0.0d0
27626 !c!-------------------------------------------------------------------
27627 !c! Elj
27628        pom = (pis / Rhead)**6.0d0
27629        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27630 !c! derivative of Elj is Glj
27631        dGLJdR = 4.0d0 * eps_head &
27632          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27633          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27634 !c!-------------------------------------------------------------------
27635 !c! Return the results
27636 !c! (see comments in Eqq)
27637        DO k = 1, 3
27638       erhead(k) = Rhead_distance(k)/Rhead
27639       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27640        END DO
27641        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27642        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27643        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
27644        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27645        facd1 = d1 * vbld_inv(i+nres)
27646        facd2 = d2 * vbld_inv(j+nres)
27647        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
27648        DO k = 1, 3
27649       condor = (erhead_tail(k,2) &
27650        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
27651
27652       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27653       gvdwx(k,i) = gvdwx(k,i) &
27654               - dGCLdR * pom &
27655               - dPOLdR2 * (erhead_tail(k,2) &
27656        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27657               - dGLJdR * pom
27658
27659       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27660       gvdwx(k,j) = gvdwx(k,j) &
27661               + dGCLdR * pom &
27662               + dPOLdR2 * condor &
27663               + dGLJdR * pom
27664
27665
27666       gvdwc(k,i) = gvdwc(k,i) &
27667               - dGCLdR * erhead(k) &
27668               - dPOLdR2 * erhead_tail(k,2) &
27669               - dGLJdR * erhead(k)
27670
27671       gvdwc(k,j) = gvdwc(k,j) &
27672               + dGCLdR * erhead(k) &
27673               + dPOLdR2 * erhead_tail(k,2) &
27674               + dGLJdR * erhead(k)
27675
27676        END DO
27677        RETURN
27678       END SUBROUTINE edq
27679
27680       SUBROUTINE edq_cat(Ecl,Elj,Epol)
27681       use comm_momo
27682       use calc_data
27683
27684       double precision  facd3, adler,ecl,elj,epol
27685        alphapol2 = alphapolcat(itypi,itypj)
27686        w1        = wqdipcat(1,itypi,itypj)
27687        w2        = wqdipcat(2,itypi,itypj)
27688        pis       = sig0headcat(itypi,itypj)
27689        eps_head  = epsheadcat(itypi,itypj)
27690 !c!-------------------------------------------------------------------
27691 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27692        R2 = 0.0d0
27693        DO k = 1, 3
27694 !c! Calculate head-to-tail distances
27695       R2=R2+(chead(k,2)-ctail(k,1))**2
27696        END DO
27697 !c! Pitagoras
27698        R2 = dsqrt(R2)
27699
27700 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27701 !c!     &        +dhead(1,1,itypi,itypj))**2))
27702 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27703 !c!     &        +dhead(2,1,itypi,itypj))**2))
27704
27705
27706 !c!-------------------------------------------------------------------
27707 !c! ecl
27708 !       write(iout,*) "KURWA2",Rhead
27709        sparrow  = w1 * Qj * om1
27710        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27711        ECL = sparrow / Rhead**2.0d0 &
27712          - hawk    / Rhead**4.0d0
27713 !c!-------------------------------------------------------------------
27714 !c! derivative of ecl is Gcl
27715 !c! dF/dr part
27716        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27717              + 4.0d0 * hawk    / Rhead**5.0d0
27718 !c! dF/dom1
27719        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27720 !c! dF/dom2
27721        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27722 !c--------------------------------------------------------------------
27723 !c--------------------------------------------------------------------
27724 !c Polarization energy
27725 !c Epol
27726        MomoFac2 = (1.0d0 - chi2 * sqom1)
27727        RR2  = R2 * R2 / MomoFac2
27728        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27729        fgb2 = sqrt(RR2  + a12sq * ee2)
27730        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27731        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27732              / (fgb2 ** 5.0d0)
27733        dFGBdR2 = ( (R2 / MomoFac2)  &
27734              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27735              / (2.0d0 * fgb2)
27736        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27737             * (2.0d0 - 0.5d0 * ee2) ) &
27738             / (2.0d0 * fgb2)
27739        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27740 !c!       dPOLdR2 = 0.0d0
27741        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27742 !c!       dPOLdOM1 = 0.0d0
27743        dPOLdOM2 = 0.0d0
27744 !c!-------------------------------------------------------------------
27745 !c! Elj
27746        pom = (pis / Rhead)**6.0d0
27747        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27748 !c! derivative of Elj is Glj
27749        dGLJdR = 4.0d0 * eps_head &
27750          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27751          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27752 !c!-------------------------------------------------------------------
27753
27754 !c! Return the results
27755 !c! (see comments in Eqq)
27756        DO k = 1, 3
27757       erhead(k) = Rhead_distance(k)/Rhead
27758       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27759        END DO
27760        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27761        erdxj = scalar( erhead(1), dC_norm(1,j) )
27762        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27763        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
27764        facd1 = d1 * vbld_inv(i+nres)
27765        facd2 = d2 * vbld_inv(j)
27766        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+nres)
27767        DO k = 1, 3
27768       condor = (erhead_tail(k,2) &
27769        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27770
27771       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27772       gradpepcatx(k,i) = gradpepcatx(k,i) &
27773               - dGCLdR * pom &
27774               - dPOLdR2 * (erhead_tail(k,2) &
27775        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27776               - dGLJdR * pom
27777
27778       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27779 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
27780 !                  + dGCLdR * pom &
27781 !                  + dPOLdR2 * condor &
27782 !                  + dGLJdR * pom
27783
27784
27785       gradpepcat(k,i) = gradpepcat(k,i) &
27786               - dGCLdR * erhead(k) &
27787               - dPOLdR2 * erhead_tail(k,2) &
27788               - dGLJdR * erhead(k)
27789
27790       gradpepcat(k,j) = gradpepcat(k,j) &
27791               + dGCLdR * erhead(k) &
27792               + dPOLdR2 * erhead_tail(k,2) &
27793               + dGLJdR * erhead(k)
27794
27795        END DO
27796        RETURN
27797       END SUBROUTINE edq_cat
27798
27799       SUBROUTINE edq_cat_pep(Ecl,Elj,Epol)
27800       use comm_momo
27801       use calc_data
27802
27803       double precision  facd3, adler,ecl,elj,epol
27804        alphapol2 = alphapolcat(itypi,itypj)
27805        w1        = wqdipcat(1,itypi,itypj)
27806        w2        = wqdipcat(2,itypi,itypj)
27807        pis       = sig0headcat(itypi,itypj)
27808        eps_head  = epsheadcat(itypi,itypj)
27809 !c!-------------------------------------------------------------------
27810 !c! R2 - distance between head of jth side chain and tail of ith sidechain
27811        R2 = 0.0d0
27812        DO k = 1, 3
27813 !c! Calculate head-to-tail distances
27814       R2=R2+(chead(k,2)-ctail(k,1))**2
27815        END DO
27816 !c! Pitagoras
27817        R2 = dsqrt(R2)
27818
27819 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
27820 !c!     &        +dhead(1,1,itypi,itypj))**2))
27821 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
27822 !c!     &        +dhead(2,1,itypi,itypj))**2))
27823
27824
27825 !c!-------------------------------------------------------------------
27826 !c! ecl
27827        sparrow  = w1 * Qj * om1
27828        hawk     = w2 * Qj * Qj * (1.0d0 - sqom2)
27829 !       print *,"CO2", itypi,itypj
27830 !       print *,"CO?!.", w1,w2,Qj,om1
27831        ECL = sparrow / Rhead**2.0d0 &
27832          - hawk    / Rhead**4.0d0
27833 !c!-------------------------------------------------------------------
27834 !c! derivative of ecl is Gcl
27835 !c! dF/dr part
27836        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
27837              + 4.0d0 * hawk    / Rhead**5.0d0
27838 !c! dF/dom1
27839        dGCLdOM1 = (w1 * Qj) / (Rhead**2.0d0)
27840 !c! dF/dom2
27841        dGCLdOM2 = (2.0d0 * w2 * Qj * Qj * om2) / (Rhead ** 4.0d0)
27842 !c--------------------------------------------------------------------
27843 !c--------------------------------------------------------------------
27844 !c Polarization energy
27845 !c Epol
27846        MomoFac2 = (1.0d0 - chi2 * sqom1)
27847        RR2  = R2 * R2 / MomoFac2
27848        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
27849        fgb2 = sqrt(RR2  + a12sq * ee2)
27850        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
27851        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
27852              / (fgb2 ** 5.0d0)
27853        dFGBdR2 = ( (R2 / MomoFac2)  &
27854              * ( 2.0d0 - (0.5d0 * ee2) ) ) &
27855              / (2.0d0 * fgb2)
27856        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
27857             * (2.0d0 - 0.5d0 * ee2) ) &
27858             / (2.0d0 * fgb2)
27859        dPOLdR2 = dPOLdFGB2 * dFGBdR2
27860 !c!       dPOLdR2 = 0.0d0
27861        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
27862 !c!       dPOLdOM1 = 0.0d0
27863        dPOLdOM2 = 0.0d0
27864 !c!-------------------------------------------------------------------
27865 !c! Elj
27866        pom = (pis / Rhead)**6.0d0
27867        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
27868 !c! derivative of Elj is Glj
27869        dGLJdR = 4.0d0 * eps_head &
27870          * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
27871          +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
27872 !c!-------------------------------------------------------------------
27873
27874 !c! Return the results
27875 !c! (see comments in Eqq)
27876        DO k = 1, 3
27877       erhead(k) = Rhead_distance(k)/Rhead
27878       erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
27879        END DO
27880        erdxi = scalar( erhead(1), dC_norm(1,i) )
27881        erdxj = scalar( erhead(1), dC_norm(1,j) )
27882        eagle = scalar( erhead_tail(1,2), dC_norm(1,j) )
27883        adler = scalar( erhead_tail(1,2), dC_norm(1,i) )
27884        facd1 = d1 * vbld_inv(i+1)/2.0
27885        facd2 = d2 * vbld_inv(j)
27886        facd3 = dtailcat(1,itypi,itypj) * vbld_inv(i+1)/2.0
27887        DO k = 1, 3
27888       condor = (erhead_tail(k,2) &
27889        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j)))
27890
27891       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i))
27892 !        gradpepcatx(k,i) = gradpepcatx(k,i) &
27893 !                  - dGCLdR * pom &
27894 !                  - dPOLdR2 * (erhead_tail(k,2) &
27895 !       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
27896 !                  - dGLJdR * pom
27897
27898       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
27899 !        gradpepcatx(k,j) = gradpepcatx(k,j) &
27900 !                  + dGCLdR * pom &
27901 !                  + dPOLdR2 * condor &
27902 !                  + dGLJdR * pom
27903
27904
27905       gradpepcat(k,i) = gradpepcat(k,i) +0.5d0*( &
27906               - dGCLdR * erhead(k) &
27907               - dPOLdR2 * erhead_tail(k,2) &
27908               - dGLJdR * erhead(k))
27909       gradpepcat(k,i+1) = gradpepcat(k,i+1) +0.5d0*( &
27910               - dGCLdR * erhead(k) &
27911               - dPOLdR2 * erhead_tail(k,2) &
27912               - dGLJdR * erhead(k))
27913
27914
27915       gradpepcat(k,j) = gradpepcat(k,j) &
27916               + dGCLdR * erhead(k) &
27917               + dPOLdR2 * erhead_tail(k,2) &
27918               + dGLJdR * erhead(k)
27919
27920        END DO
27921        RETURN
27922       END SUBROUTINE edq_cat_pep
27923
27924       SUBROUTINE edd(ECL)
27925 !       IMPLICIT NONE
27926        use comm_momo
27927       use calc_data
27928
27929        double precision ecl
27930 !c!       csig = sigiso(itypi,itypj)
27931        w1 = wqdip(1,itypi,itypj)
27932        w2 = wqdip(2,itypi,itypj)
27933 !c!-------------------------------------------------------------------
27934 !c! ECL
27935        fac = (om12 - 3.0d0 * om1 * om2)
27936        c1 = (w1 / (Rhead**3.0d0)) * fac
27937        c2 = (w2 / Rhead ** 6.0d0) &
27938         * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27939        ECL = c1 - c2
27940 !c!       write (*,*) "w1 = ", w1
27941 !c!       write (*,*) "w2 = ", w2
27942 !c!       write (*,*) "om1 = ", om1
27943 !c!       write (*,*) "om2 = ", om2
27944 !c!       write (*,*) "om12 = ", om12
27945 !c!       write (*,*) "fac = ", fac
27946 !c!       write (*,*) "c1 = ", c1
27947 !c!       write (*,*) "c2 = ", c2
27948 !c!       write (*,*) "Ecl = ", Ecl
27949 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
27950 !c!       write (*,*) "c2_2 = ",
27951 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
27952 !c!-------------------------------------------------------------------
27953 !c! dervative of ECL is GCL...
27954 !c! dECL/dr
27955        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
27956        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
27957         * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
27958        dGCLdR = c1 - c2
27959 !c! dECL/dom1
27960        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
27961        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27962         * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
27963        dGCLdOM1 = c1 - c2
27964 !c! dECL/dom2
27965        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
27966        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
27967         * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
27968        dGCLdOM2 = c1 - c2
27969 !c! dECL/dom12
27970        c1 = w1 / (Rhead ** 3.0d0)
27971        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
27972        dGCLdOM12 = c1 - c2
27973 !c!-------------------------------------------------------------------
27974 !c! Return the results
27975 !c! (see comments in Eqq)
27976        DO k= 1, 3
27977       erhead(k) = Rhead_distance(k)/Rhead
27978        END DO
27979        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
27980        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
27981        facd1 = d1 * vbld_inv(i+nres)
27982        facd2 = d2 * vbld_inv(j+nres)
27983        DO k = 1, 3
27984
27985       pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
27986       gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
27987       pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
27988       gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
27989
27990       gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
27991       gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
27992        END DO
27993        RETURN
27994       END SUBROUTINE edd
27995       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
27996 !       IMPLICIT NONE
27997        use comm_momo
27998       use calc_data
27999
28000        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
28001        eps_out=80.0d0
28002        itypi = itype(i,1)
28003        itypj = itype(j,1)
28004 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
28005 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
28006 !c!       t_bath = 300
28007 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
28008        Rb=0.001986d0
28009        BetaT = 1.0d0 / (298.0d0 * Rb)
28010 !c! Gay-berne var's
28011        sig0ij = sigma( itypi,itypj )
28012        chi1   = chi( itypi, itypj )
28013        chi2   = chi( itypj, itypi )
28014        chi12  = chi1 * chi2
28015        chip1  = chipp( itypi, itypj )
28016        chip2  = chipp( itypj, itypi )
28017        chip12 = chip1 * chip2
28018 !       chi1=0.0
28019 !       chi2=0.0
28020 !       chi12=0.0
28021 !       chip1=0.0
28022 !       chip2=0.0
28023 !       chip12=0.0
28024 !c! not used by momo potential, but needed by sc_angular which is shared
28025 !c! by all energy_potential subroutines
28026        alf1   = 0.0d0
28027        alf2   = 0.0d0
28028        alf12  = 0.0d0
28029 !c! location, location, location
28030 !       xj  = c( 1, nres+j ) - xi
28031 !       yj  = c( 2, nres+j ) - yi
28032 !       zj  = c( 3, nres+j ) - zi
28033        dxj = dc_norm( 1, nres+j )
28034        dyj = dc_norm( 2, nres+j )
28035        dzj = dc_norm( 3, nres+j )
28036 !c! distance from center of chain(?) to polar/charged head
28037 !c!       write (*,*) "istate = ", 1
28038 !c!       write (*,*) "ii = ", 1
28039 !c!       write (*,*) "jj = ", 1
28040        d1 = dhead(1, 1, itypi, itypj)
28041        d2 = dhead(2, 1, itypi, itypj)
28042 !c! ai*aj from Fgb
28043        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
28044 !c!       a12sq = a12sq * a12sq
28045 !c! charge of amino acid itypi is...
28046        Qi  = icharge(itypi)
28047        Qj  = icharge(itypj)
28048        Qij = Qi * Qj
28049 !c! chis1,2,12
28050        chis1 = chis(itypi,itypj)
28051        chis2 = chis(itypj,itypi)
28052        chis12 = chis1 * chis2
28053        sig1 = sigmap1(itypi,itypj)
28054        sig2 = sigmap2(itypi,itypj)
28055 !c!       write (*,*) "sig1 = ", sig1
28056 !c!       write (*,*) "sig2 = ", sig2
28057 !c! alpha factors from Fcav/Gcav
28058        b1cav = alphasur(1,itypi,itypj)
28059 !       b1cav=0.0
28060        b2cav = alphasur(2,itypi,itypj)
28061        b3cav = alphasur(3,itypi,itypj)
28062        b4cav = alphasur(4,itypi,itypj)
28063        wqd = wquad(itypi, itypj)
28064 !c! used by Fgb
28065        eps_in = epsintab(itypi,itypj)
28066        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
28067 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
28068 !c!-------------------------------------------------------------------
28069 !c! tail location and distance calculations
28070        Rtail = 0.0d0
28071        DO k = 1, 3
28072       ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
28073       ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
28074        END DO
28075 !c! tail distances will be themselves usefull elswhere
28076 !c1 (in Gcav, for example)
28077        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
28078        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
28079        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
28080        Rtail = dsqrt(  &
28081         (Rtail_distance(1)*Rtail_distance(1))  &
28082       + (Rtail_distance(2)*Rtail_distance(2))  &
28083       + (Rtail_distance(3)*Rtail_distance(3)))
28084 !c!-------------------------------------------------------------------
28085 !c! Calculate location and distance between polar heads
28086 !c! distance between heads
28087 !c! for each one of our three dimensional space...
28088        d1 = dhead(1, 1, itypi, itypj)
28089        d2 = dhead(2, 1, itypi, itypj)
28090
28091        DO k = 1,3
28092 !c! location of polar head is computed by taking hydrophobic centre
28093 !c! and moving by a d1 * dc_norm vector
28094 !c! see unres publications for very informative images
28095       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
28096       chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
28097 !c! distance
28098 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
28099 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
28100       Rhead_distance(k) = chead(k,2) - chead(k,1)
28101        END DO
28102 !c! pitagoras (root of sum of squares)
28103        Rhead = dsqrt(   &
28104         (Rhead_distance(1)*Rhead_distance(1)) &
28105       + (Rhead_distance(2)*Rhead_distance(2)) &
28106       + (Rhead_distance(3)*Rhead_distance(3)))
28107 !c!-------------------------------------------------------------------
28108 !c! zero everything that should be zero'ed
28109        Egb = 0.0d0
28110        ECL = 0.0d0
28111        Elj = 0.0d0
28112        Equad = 0.0d0
28113        Epol = 0.0d0
28114        eheadtail = 0.0d0
28115        dGCLdOM1 = 0.0d0
28116        dGCLdOM2 = 0.0d0
28117        dGCLdOM12 = 0.0d0
28118        dPOLdOM1 = 0.0d0
28119        dPOLdOM2 = 0.0d0
28120        RETURN
28121       END SUBROUTINE elgrad_init
28122
28123
28124       SUBROUTINE elgrad_init_cat(eheadtail,Egb,Ecl,Elj,Equad,Epol)
28125       use comm_momo
28126       use calc_data
28127        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
28128        eps_out=80.0d0
28129        itypi = itype(i,1)
28130        itypj = itype(j,5)
28131 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
28132 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
28133 !c!       t_bath = 300
28134 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
28135        Rb=0.001986d0
28136        BetaT = 1.0d0 / (298.0d0 * Rb)
28137 !c! Gay-berne var's
28138        sig0ij = sigmacat( itypi,itypj )
28139        chi1   = chi1cat( itypi, itypj )
28140        chi2   = 0.0d0
28141        chi12  = 0.0d0
28142        chip1  = chipp1cat( itypi, itypj )
28143        chip2  = 0.0d0
28144        chip12 = 0.0d0
28145 !c! not used by momo potential, but needed by sc_angular which is shared
28146 !c! by all energy_potential subroutines
28147        alf1   = 0.0d0
28148        alf2   = 0.0d0
28149        alf12  = 0.0d0
28150        dxj = 0.0d0 !dc_norm( 1, nres+j )
28151        dyj = 0.0d0 !dc_norm( 2, nres+j )
28152        dzj = 0.0d0 !dc_norm( 3, nres+j )
28153 !c! distance from center of chain(?) to polar/charged head
28154        d1 = dheadcat(1, 1, itypi, itypj)
28155        d2 = dheadcat(2, 1, itypi, itypj)
28156 !c! ai*aj from Fgb
28157        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
28158 !c!       a12sq = a12sq * a12sq
28159 !c! charge of amino acid itypi is...
28160        Qi  = icharge(itypi)
28161        Qj  = ichargecat(itypj)
28162        Qij = Qi * Qj
28163 !c! chis1,2,12
28164        chis1 = chis1cat(itypi,itypj)
28165        chis2 = 0.0d0
28166        chis12 = 0.0d0
28167        sig1 = sigmap1cat(itypi,itypj)
28168        sig2 = sigmap2cat(itypi,itypj)
28169 !c! alpha factors from Fcav/Gcav
28170        b1cav = alphasurcat(1,itypi,itypj)
28171        b2cav = alphasurcat(2,itypi,itypj)
28172        b3cav = alphasurcat(3,itypi,itypj)
28173        b4cav = alphasurcat(4,itypi,itypj)
28174        wqd = wquadcat(itypi, itypj)
28175 !c! used by Fgb
28176        eps_in = epsintabcat(itypi,itypj)
28177        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
28178 !c!-------------------------------------------------------------------
28179 !c! tail location and distance calculations
28180        Rtail = 0.0d0
28181        DO k = 1, 3
28182       ctail(k,1)=c(k,i+nres)-dtailcat(1,itypi,itypj)*dc_norm(k,nres+i)
28183       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
28184        END DO
28185 !c! tail distances will be themselves usefull elswhere
28186 !c1 (in Gcav, for example)
28187        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
28188        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
28189        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
28190        Rtail = dsqrt(  &
28191         (Rtail_distance(1)*Rtail_distance(1))  &
28192       + (Rtail_distance(2)*Rtail_distance(2))  &
28193       + (Rtail_distance(3)*Rtail_distance(3)))
28194 !c!-------------------------------------------------------------------
28195 !c! Calculate location and distance between polar heads
28196 !c! distance between heads
28197 !c! for each one of our three dimensional space...
28198        d1 = dheadcat(1, 1, itypi, itypj)
28199        d2 = dheadcat(2, 1, itypi, itypj)
28200
28201        DO k = 1,3
28202 !c! location of polar head is computed by taking hydrophobic centre
28203 !c! and moving by a d1 * dc_norm vector
28204 !c! see unres publications for very informative images
28205       chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
28206       chead(k,2) = c(k, j)
28207 !c! distance
28208 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
28209 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
28210       Rhead_distance(k) = chead(k,2) - chead(k,1)
28211        END DO
28212 !c! pitagoras (root of sum of squares)
28213        Rhead = dsqrt(   &
28214         (Rhead_distance(1)*Rhead_distance(1)) &
28215       + (Rhead_distance(2)*Rhead_distance(2)) &
28216       + (Rhead_distance(3)*Rhead_distance(3)))
28217 !c!-------------------------------------------------------------------
28218 !c! zero everything that should be zero'ed
28219        Egb = 0.0d0
28220        ECL = 0.0d0
28221        Elj = 0.0d0
28222        Equad = 0.0d0
28223        Epol = 0.0d0
28224        eheadtail = 0.0d0
28225        dGCLdOM1 = 0.0d0
28226        dGCLdOM2 = 0.0d0
28227        dGCLdOM12 = 0.0d0
28228        dPOLdOM1 = 0.0d0
28229        dPOLdOM2 = 0.0d0
28230        RETURN
28231       END SUBROUTINE elgrad_init_cat
28232
28233       SUBROUTINE elgrad_init_cat_pep(eheadtail,Egb,Ecl,Elj,Equad,Epol)
28234       use comm_momo
28235       use calc_data
28236        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
28237        eps_out=80.0d0
28238        itypi = 10
28239        itypj = itype(j,5)
28240 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
28241 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
28242 !c!       t_bath = 300
28243 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
28244        Rb=0.001986d0
28245        BetaT = 1.0d0 / (298.0d0 * Rb)
28246 !c! Gay-berne var's
28247        sig0ij = sigmacat( itypi,itypj )
28248        chi1   = chi1cat( itypi, itypj )
28249        chi2   = 0.0d0
28250        chi12  = 0.0d0
28251        chip1  = chipp1cat( itypi, itypj )
28252        chip2  = 0.0d0
28253        chip12 = 0.0d0
28254 !c! not used by momo potential, but needed by sc_angular which is shared
28255 !c! by all energy_potential subroutines
28256        alf1   = 0.0d0
28257        alf2   = 0.0d0
28258        alf12  = 0.0d0
28259        dxj = 0.0d0 !dc_norm( 1, nres+j )
28260        dyj = 0.0d0 !dc_norm( 2, nres+j )
28261        dzj = 0.0d0 !dc_norm( 3, nres+j )
28262 !c! distance from center of chain(?) to polar/charged head
28263        d1 = dheadcat(1, 1, itypi, itypj)
28264        d2 = dheadcat(2, 1, itypi, itypj)
28265 !c! ai*aj from Fgb
28266        a12sq = rborn1cat(itypi,itypj) * rborn2cat(itypi,itypj)
28267 !c!       a12sq = a12sq * a12sq
28268 !c! charge of amino acid itypi is...
28269        Qi  = 0
28270        Qj  = ichargecat(itypj)
28271 !       Qij = Qi * Qj
28272 !c! chis1,2,12
28273        chis1 = chis1cat(itypi,itypj)
28274        chis2 = 0.0d0
28275        chis12 = 0.0d0
28276        sig1 = sigmap1cat(itypi,itypj)
28277        sig2 = sigmap2cat(itypi,itypj)
28278 !c! alpha factors from Fcav/Gcav
28279        b1cav = alphasurcat(1,itypi,itypj)
28280        b2cav = alphasurcat(2,itypi,itypj)
28281        b3cav = alphasurcat(3,itypi,itypj)
28282        b4cav = alphasurcat(4,itypi,itypj)
28283        wqd = wquadcat(itypi, itypj)
28284 !c! used by Fgb
28285        eps_in = epsintabcat(itypi,itypj)
28286        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
28287 !c!-------------------------------------------------------------------
28288 !c! tail location and distance calculations
28289        Rtail = 0.0d0
28290        DO k = 1, 3
28291       ctail(k,1)=(c(k,i)+c(k,i+1))/2.0-dtailcat(1,itypi,itypj)*dc_norm(k,i)
28292       ctail(k,2)=c(k,j)!-dtailcat(2,itypi,itypj)*dc_norm(k,nres+j)
28293        END DO
28294 !c! tail distances will be themselves usefull elswhere
28295 !c1 (in Gcav, for example)
28296        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
28297        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
28298        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
28299        Rtail = dsqrt(  &
28300         (Rtail_distance(1)*Rtail_distance(1))  &
28301       + (Rtail_distance(2)*Rtail_distance(2))  &
28302       + (Rtail_distance(3)*Rtail_distance(3)))
28303 !c!-------------------------------------------------------------------
28304 !c! Calculate location and distance between polar heads
28305 !c! distance between heads
28306 !c! for each one of our three dimensional space...
28307        d1 = dheadcat(1, 1, itypi, itypj)
28308        d2 = dheadcat(2, 1, itypi, itypj)
28309
28310        DO k = 1,3
28311 !c! location of polar head is computed by taking hydrophobic centre
28312 !c! and moving by a d1 * dc_norm vector
28313 !c! see unres publications for very informative images
28314       chead(k,1) = (c(k, i)+c(k,i+1))/2.0 + d1 * dc_norm(k, i)
28315       chead(k,2) = c(k, j)
28316 !c! distance
28317 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
28318 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
28319       Rhead_distance(k) = chead(k,2) - chead(k,1)
28320        END DO
28321 !c! pitagoras (root of sum of squares)
28322        Rhead = dsqrt(   &
28323         (Rhead_distance(1)*Rhead_distance(1)) &
28324       + (Rhead_distance(2)*Rhead_distance(2)) &
28325       + (Rhead_distance(3)*Rhead_distance(3)))
28326 !c!-------------------------------------------------------------------
28327 !c! zero everything that should be zero'ed
28328        Egb = 0.0d0
28329        ECL = 0.0d0
28330        Elj = 0.0d0
28331        Equad = 0.0d0
28332        Epol = 0.0d0
28333        eheadtail = 0.0d0
28334        dGCLdOM1 = 0.0d0
28335        dGCLdOM2 = 0.0d0
28336        dGCLdOM12 = 0.0d0
28337        dPOLdOM1 = 0.0d0
28338        dPOLdOM2 = 0.0d0
28339        RETURN
28340       END SUBROUTINE elgrad_init_cat_pep
28341
28342       double precision function tschebyshev(m,n,x,y)
28343       implicit none
28344       integer i,m,n
28345       double precision x(n),y,yy(0:maxvar),aux
28346 !c Tschebyshev polynomial. Note that the first term is omitted
28347 !c m=0: the constant term is included
28348 !c m=1: the constant term is not included
28349       yy(0)=1.0d0
28350       yy(1)=y
28351       do i=2,n
28352       yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
28353       enddo
28354       aux=0.0d0
28355       do i=m,n
28356       aux=aux+x(i)*yy(i)
28357       enddo
28358       tschebyshev=aux
28359       return
28360       end function tschebyshev
28361 !C--------------------------------------------------------------------------
28362       double precision function gradtschebyshev(m,n,x,y)
28363       implicit none
28364       integer i,m,n
28365       double precision x(n+1),y,yy(0:maxvar),aux
28366 !c Tschebyshev polynomial. Note that the first term is omitted
28367 !c m=0: the constant term is included
28368 !c m=1: the constant term is not included
28369       yy(0)=1.0d0
28370       yy(1)=2.0d0*y
28371       do i=2,n
28372       yy(i)=2*y*yy(i-1)-yy(i-2)
28373       enddo
28374       aux=0.0d0
28375       do i=m,n
28376       aux=aux+x(i+1)*yy(i)*(i+1)
28377 !C        print *, x(i+1),yy(i),i
28378       enddo
28379       gradtschebyshev=aux
28380       return
28381       end function gradtschebyshev
28382
28383       subroutine make_SCSC_inter_list
28384       include 'mpif.h'
28385       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
28386       real*8 :: dist_init, dist_temp,r_buff_list
28387       integer:: contlisti(250*nres),contlistj(250*nres)
28388 !      integer :: newcontlisti(200*nres),newcontlistj(200*nres)
28389       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_sc,g_ilist_sc
28390       integer displ(0:nprocs),i_ilist_sc(0:nprocs),ierr
28391 !            print *,"START make_SC"
28392         r_buff_list=5.0
28393           ilist_sc=0
28394           do i=iatsc_s,iatsc_e
28395            itypi=iabs(itype(i,1))
28396            if (itypi.eq.ntyp1) cycle
28397            xi=c(1,nres+i)
28398            yi=c(2,nres+i)
28399            zi=c(3,nres+i)
28400           call to_box(xi,yi,zi)
28401            do iint=1,nint_gr(i)
28402 !           print *,"is it wrong", iint,i
28403             do j=istart(i,iint),iend(i,iint)
28404              itypj=iabs(itype(j,1))
28405              if (energy_dec) write(iout,*) "LISTA ZAKRES",istart(i,iint),iend(i,iint),iatsc_s,iatsc_e
28406              if (itypj.eq.ntyp1) cycle
28407              xj=c(1,nres+j)
28408              yj=c(2,nres+j)
28409              zj=c(3,nres+j)
28410              call to_box(xj,yj,zj)
28411 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
28412 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
28413           xj=boxshift(xj-xi,boxxsize)
28414           yj=boxshift(yj-yi,boxysize)
28415           zj=boxshift(zj-zi,boxzsize)
28416           dist_init=xj**2+yj**2+zj**2
28417 !             dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
28418 ! r_buff_list is a read value for a buffer
28419              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
28420 ! Here the list is created
28421              ilist_sc=ilist_sc+1
28422 ! this can be substituted by cantor and anti-cantor
28423              contlisti(ilist_sc)=i
28424              contlistj(ilist_sc)=j
28425
28426              endif
28427            enddo
28428            enddo
28429            enddo
28430 !         call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
28431 !          MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
28432 !        call MPI_Gather(newnss,1,MPI_INTEGER,&
28433 !                        i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
28434 #ifdef DEBUG
28435       write (iout,*) "before MPIREDUCE",ilist_sc
28436       do i=1,ilist_sc
28437       write (iout,*) i,contlisti(i),contlistj(i)
28438       enddo
28439 #endif
28440       if (nfgtasks.gt.1)then
28441
28442       call MPI_Reduce(ilist_sc,g_ilist_sc,1,&
28443         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
28444 !        write(iout,*) "before bcast",g_ilist_sc
28445       call MPI_Gather(ilist_sc,1,MPI_INTEGER,&
28446                   i_ilist_sc,1,MPI_INTEGER,king,FG_COMM,IERR)
28447       displ(0)=0
28448       do i=1,nfgtasks-1,1
28449         displ(i)=i_ilist_sc(i-1)+displ(i-1)
28450       enddo
28451 !        write(iout,*) "before gather",displ(0),displ(1)
28452       call MPI_Gatherv(contlisti,ilist_sc,MPI_INTEGER,&
28453                    newcontlisti,i_ilist_sc,displ,MPI_INTEGER,&
28454                    king,FG_COMM,IERR)
28455       call MPI_Gatherv(contlistj,ilist_sc,MPI_INTEGER,&
28456                    newcontlistj,i_ilist_sc,displ,MPI_INTEGER,&
28457                    king,FG_COMM,IERR)
28458       call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM,IERR)
28459 !        write(iout,*) "before bcast",g_ilist_sc
28460 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28461       call MPI_Bcast(newcontlisti,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
28462       call MPI_Bcast(newcontlistj,g_ilist_sc,MPI_INT,king,FG_COMM,IERR)
28463
28464 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28465
28466       else
28467       g_ilist_sc=ilist_sc
28468
28469       do i=1,ilist_sc
28470       newcontlisti(i)=contlisti(i)
28471       newcontlistj(i)=contlistj(i)
28472       enddo
28473       endif
28474
28475 #ifdef DEBUG
28476       write (iout,*) "after MPIREDUCE",g_ilist_sc
28477       do i=1,g_ilist_sc
28478       write (iout,*) i,newcontlisti(i),newcontlistj(i)
28479       enddo
28480 #endif
28481       call int_bounds(g_ilist_sc,g_listscsc_start,g_listscsc_end)
28482       return
28483       end subroutine make_SCSC_inter_list
28484 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
28485
28486       subroutine make_SCp_inter_list
28487       use MD_data,  only: itime_mat
28488
28489       include 'mpif.h'
28490       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
28491       real*8 :: dist_init, dist_temp,r_buff_list
28492       integer:: contlistscpi(350*nres),contlistscpj(350*nres)
28493 !      integer :: newcontlistscpi(200*nres),newcontlistscpj(200*nres)
28494       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_scp,g_ilist_scp
28495       integer displ(0:nprocs),i_ilist_scp(0:nprocs),ierr
28496 !            print *,"START make_SC"
28497       r_buff_list=5.0
28498           ilist_scp=0
28499       do i=iatscp_s,iatscp_e
28500       if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
28501       xi=0.5D0*(c(1,i)+c(1,i+1))
28502       yi=0.5D0*(c(2,i)+c(2,i+1))
28503       zi=0.5D0*(c(3,i)+c(3,i+1))
28504         call to_box(xi,yi,zi)
28505       do iint=1,nscp_gr(i)
28506
28507       do j=iscpstart(i,iint),iscpend(i,iint)
28508         itypj=iabs(itype(j,1))
28509         if (itypj.eq.ntyp1) cycle
28510 ! Uncomment following three lines for SC-p interactions
28511 !         xj=c(1,nres+j)-xi
28512 !         yj=c(2,nres+j)-yi
28513 !         zj=c(3,nres+j)-zi
28514 ! Uncomment following three lines for Ca-p interactions
28515 !          xj=c(1,j)-xi
28516 !          yj=c(2,j)-yi
28517 !          zj=c(3,j)-zi
28518         xj=c(1,j)
28519         yj=c(2,j)
28520         zj=c(3,j)
28521         call to_box(xj,yj,zj)
28522       xj=boxshift(xj-xi,boxxsize)
28523       yj=boxshift(yj-yi,boxysize)
28524       zj=boxshift(zj-zi,boxzsize)
28525       dist_init=xj**2+yj**2+zj**2
28526 #ifdef DEBUG
28527             ! r_buff_list is a read value for a buffer
28528              if ((sqrt(dist_init).le.(r_cut_ele)).and.(ifirstrun.eq.0)) then
28529 ! Here the list is created
28530              ilist_scp_first=ilist_scp_first+1
28531 ! this can be substituted by cantor and anti-cantor
28532              contlistscpi_f(ilist_scp_first)=i
28533              contlistscpj_f(ilist_scp_first)=j
28534             endif
28535 #endif
28536 ! r_buff_list is a read value for a buffer
28537              if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
28538 ! Here the list is created
28539              ilist_scp=ilist_scp+1
28540 ! this can be substituted by cantor and anti-cantor
28541              contlistscpi(ilist_scp)=i
28542              contlistscpj(ilist_scp)=j
28543             endif
28544            enddo
28545            enddo
28546            enddo
28547 #ifdef DEBUG
28548       write (iout,*) "before MPIREDUCE",ilist_scp
28549       do i=1,ilist_scp
28550       write (iout,*) i,contlistscpi(i),contlistscpj(i)
28551       enddo
28552 #endif
28553       if (nfgtasks.gt.1)then
28554
28555       call MPI_Reduce(ilist_scp,g_ilist_scp,1,&
28556         MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
28557 !        write(iout,*) "before bcast",g_ilist_sc
28558       call MPI_Gather(ilist_scp,1,MPI_INTEGER,&
28559                   i_ilist_scp,1,MPI_INTEGER,king,FG_COMM,IERR)
28560       displ(0)=0
28561       do i=1,nfgtasks-1,1
28562         displ(i)=i_ilist_scp(i-1)+displ(i-1)
28563       enddo
28564 !        write(iout,*) "before gather",displ(0),displ(1)
28565       call MPI_Gatherv(contlistscpi,ilist_scp,MPI_INTEGER,&
28566                    newcontlistscpi,i_ilist_scp,displ,MPI_INTEGER,&
28567                    king,FG_COMM,IERR)
28568       call MPI_Gatherv(contlistscpj,ilist_scp,MPI_INTEGER,&
28569                    newcontlistscpj,i_ilist_scp,displ,MPI_INTEGER,&
28570                    king,FG_COMM,IERR)
28571       call MPI_Bcast(g_ilist_scp,1,MPI_INT,king,FG_COMM,IERR)
28572 !        write(iout,*) "before bcast",g_ilist_sc
28573 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28574       call MPI_Bcast(newcontlistscpi,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
28575       call MPI_Bcast(newcontlistscpj,g_ilist_scp,MPI_INT,king,FG_COMM,IERR)
28576
28577 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28578
28579       else
28580       g_ilist_scp=ilist_scp
28581
28582       do i=1,ilist_scp
28583       newcontlistscpi(i)=contlistscpi(i)
28584       newcontlistscpj(i)=contlistscpj(i)
28585       enddo
28586       endif
28587
28588 #ifdef DEBUG
28589       write (iout,*) "after MPIREDUCE",g_ilist_scp
28590       do i=1,g_ilist_scp
28591       write (iout,*) i,newcontlistscpi(i),newcontlistscpj(i)
28592       enddo
28593
28594 !      if (ifirstrun.eq.0) ifirstrun=1
28595 !      do i=1,ilist_scp_first
28596 !       do j=1,g_ilist_scp
28597 !        if ((newcontlistscpi(j).eq.contlistscpi_f(i)).and.&
28598 !         (newcontlistscpj(j).eq.contlistscpj_f(i))) go to 126
28599 !        enddo
28600 !       print *,itime_mat,"ERROR matrix needs updating"
28601 !       print *,contlistscpi_f(i),contlistscpj_f(i)
28602 !  126  continue
28603 !      enddo
28604 #endif
28605       call int_bounds(g_ilist_scp,g_listscp_start,g_listscp_end)
28606
28607       return
28608       end subroutine make_SCp_inter_list
28609
28610 !-----------------------------------------------------------------------------
28611 !-----------------------------------------------------------------------------
28612
28613
28614       subroutine make_pp_inter_list
28615       include 'mpif.h'
28616       real*8 :: xi,yi,zi,xj,yj,zj,xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp
28617       real*8 :: xmedj,ymedj,zmedj,sslipi,ssgradlipi,faclipij2,sslipj,ssgradlipj
28618       real*8 :: dist_init, dist_temp,r_buff_list,dxi,dyi,dzi,xmedi,ymedi,zmedi
28619       real*8 :: dx_normi,dy_normi,dz_normi,dxj,dyj,dzj,dx_normj,dy_normj,dz_normj
28620       integer:: contlistppi(250*nres),contlistppj(250*nres)
28621 !      integer :: newcontlistppi(200*nres),newcontlistppj(200*nres)
28622       integer i,j,itypi,itypj,subchap,xshift,yshift,zshift,iint,ilist_pp,g_ilist_pp
28623       integer displ(0:nprocs),i_ilist_pp(0:nprocs),ierr
28624 !            write(iout,*),"START make_pp",iatel_s,iatel_e,r_cut_ele+r_buff_list
28625             ilist_pp=0
28626       r_buff_list=5.0
28627       do i=iatel_s,iatel_e
28628         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
28629         dxi=dc(1,i)
28630         dyi=dc(2,i)
28631         dzi=dc(3,i)
28632         dx_normi=dc_norm(1,i)
28633         dy_normi=dc_norm(2,i)
28634         dz_normi=dc_norm(3,i)
28635         xmedi=c(1,i)+0.5d0*dxi
28636         ymedi=c(2,i)+0.5d0*dyi
28637         zmedi=c(3,i)+0.5d0*dzi
28638
28639         call to_box(xmedi,ymedi,zmedi)
28640         call lipid_layer(xmedi,ymedi,zmedi,sslipi,ssgradlipi)
28641 !          write (iout,*) i,j,itype(i,1),itype(j,1)
28642 !          if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
28643
28644 ! 1,j)
28645              do j=ielstart(i),ielend(i)
28646 !          write (iout,*) i,j,itype(i,1),itype(j,1)
28647           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
28648           dxj=dc(1,j)
28649           dyj=dc(2,j)
28650           dzj=dc(3,j)
28651           dx_normj=dc_norm(1,j)
28652           dy_normj=dc_norm(2,j)
28653           dz_normj=dc_norm(3,j)
28654 !          xj=c(1,j)+0.5D0*dxj-xmedi
28655 !          yj=c(2,j)+0.5D0*dyj-ymedi
28656 !          zj=c(3,j)+0.5D0*dzj-zmedi
28657           xj=c(1,j)+0.5D0*dxj
28658           yj=c(2,j)+0.5D0*dyj
28659           zj=c(3,j)+0.5D0*dzj
28660           call to_box(xj,yj,zj)
28661 !          call lipid_layer(xj,yj,zj,sslipj,ssgradlipj)
28662 !          faclipij2=(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
28663           xj=boxshift(xj-xmedi,boxxsize)
28664           yj=boxshift(yj-ymedi,boxysize)
28665           zj=boxshift(zj-zmedi,boxzsize)
28666           dist_init=xj**2+yj**2+zj**2
28667       if (sqrt(dist_init).le.(r_cut_ele+r_buff_list)) then
28668 ! Here the list is created
28669                  ilist_pp=ilist_pp+1
28670 ! this can be substituted by cantor and anti-cantor
28671                  contlistppi(ilist_pp)=i
28672                  contlistppj(ilist_pp)=j
28673               endif
28674 !             enddo
28675              enddo
28676              enddo
28677 #ifdef DEBUG
28678       write (iout,*) "before MPIREDUCE",ilist_pp
28679       do i=1,ilist_pp
28680       write (iout,*) i,contlistppi(i),contlistppj(i)
28681       enddo
28682 #endif
28683       if (nfgtasks.gt.1)then
28684
28685         call MPI_Reduce(ilist_pp,g_ilist_pp,1,&
28686           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
28687 !        write(iout,*) "before bcast",g_ilist_sc
28688         call MPI_Gather(ilist_pp,1,MPI_INTEGER,&
28689                         i_ilist_pp,1,MPI_INTEGER,king,FG_COMM,IERR)
28690         displ(0)=0
28691         do i=1,nfgtasks-1,1
28692           displ(i)=i_ilist_pp(i-1)+displ(i-1)
28693         enddo
28694 !        write(iout,*) "before gather",displ(0),displ(1)
28695         call MPI_Gatherv(contlistppi,ilist_pp,MPI_INTEGER,&
28696                          newcontlistppi,i_ilist_pp,displ,MPI_INTEGER,&
28697                          king,FG_COMM,IERR)
28698         call MPI_Gatherv(contlistppj,ilist_pp,MPI_INTEGER,&
28699                          newcontlistppj,i_ilist_pp,displ,MPI_INTEGER,&
28700                          king,FG_COMM,IERR)
28701         call MPI_Bcast(g_ilist_pp,1,MPI_INT,king,FG_COMM,IERR)
28702 !        write(iout,*) "before bcast",g_ilist_sc
28703 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28704         call MPI_Bcast(newcontlistppi,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
28705         call MPI_Bcast(newcontlistppj,g_ilist_pp,MPI_INT,king,FG_COMM,IERR)
28706
28707 !        call MPI_Bcast(g_ilist_sc,1,MPI_INT,king,FG_COMM)
28708
28709         else
28710         g_ilist_pp=ilist_pp
28711
28712         do i=1,ilist_pp
28713         newcontlistppi(i)=contlistppi(i)
28714         newcontlistppj(i)=contlistppj(i)
28715         enddo
28716         endif
28717         call int_bounds(g_ilist_pp,g_listpp_start,g_listpp_end)
28718 #ifdef DEBUG
28719       write (iout,*) "after MPIREDUCE",g_ilist_pp
28720       do i=1,g_ilist_pp
28721       write (iout,*) i,newcontlistppi(i),newcontlistppj(i)
28722       enddo
28723 #endif
28724       return
28725       end subroutine make_pp_inter_list
28726
28727 !-----------------------------------------------------------------------------
28728       double precision function boxshift(x,boxsize)
28729       implicit none
28730       double precision x,boxsize
28731       double precision xtemp
28732       xtemp=dmod(x,boxsize)
28733       if (dabs(xtemp-boxsize).lt.dabs(xtemp)) then
28734         boxshift=xtemp-boxsize
28735       else if (dabs(xtemp+boxsize).lt.dabs(xtemp)) then
28736         boxshift=xtemp+boxsize
28737       else
28738         boxshift=xtemp
28739       endif
28740       return
28741       end function boxshift
28742 !-----------------------------------------------------------------------------
28743       subroutine to_box(xi,yi,zi)
28744       implicit none
28745 !      include 'DIMENSIONS'
28746 !      include 'COMMON.CHAIN'
28747       double precision xi,yi,zi
28748       xi=dmod(xi,boxxsize)
28749       if (xi.lt.0.0d0) xi=xi+boxxsize
28750       yi=dmod(yi,boxysize)
28751       if (yi.lt.0.0d0) yi=yi+boxysize
28752       zi=dmod(zi,boxzsize)
28753       if (zi.lt.0.0d0) zi=zi+boxzsize
28754       return
28755       end subroutine to_box
28756 !--------------------------------------------------------------------------
28757       subroutine lipid_layer(xi,yi,zi,sslipi,ssgradlipi)
28758       implicit none
28759 !      include 'DIMENSIONS'
28760 !      include 'COMMON.IOUNITS'
28761 !      include 'COMMON.CHAIN'
28762       double precision xi,yi,zi,sslipi,ssgradlipi
28763       double precision fracinbuf
28764 !      double precision sscalelip,sscagradlip
28765 #ifdef DEBUG
28766       write (iout,*) "bordlipbot",bordlipbot," bordliptop",bordliptop
28767       write (iout,*) "buflipbot",buflipbot," lipbufthick",lipbufthick
28768       write (iout,*) "xi yi zi",xi,yi,zi
28769 #endif
28770       if ((zi.gt.bordlipbot).and.(zi.lt.bordliptop)) then
28771 ! the energy transfer exist
28772         if (zi.lt.buflipbot) then
28773 ! what fraction I am in
28774           fracinbuf=1.0d0-((zi-bordlipbot)/lipbufthick)
28775 ! lipbufthick is thickenes of lipid buffore
28776           sslipi=sscalelip(fracinbuf)
28777           ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
28778         elseif (zi.gt.bufliptop) then
28779           fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
28780           sslipi=sscalelip(fracinbuf)
28781           ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
28782         else
28783           sslipi=1.0d0
28784           ssgradlipi=0.0
28785         endif
28786       else
28787         sslipi=0.0d0
28788         ssgradlipi=0.0
28789       endif
28790 #ifdef DEBUG
28791       write (iout,*) "sslipi",sslipi," ssgradlipi",ssgradlipi
28792 #endif
28793       return
28794       end subroutine lipid_layer
28795
28796 !--------------------------------------------------------------------------
28797 !--------------------------------------------------------------------------
28798       end module energy