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      !(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(:),allocatable :: costab,sintab,&
  91        costab2,sintab2      !(maxres)
  92 ! This common block contains dipole-interaction matrices and their
  93 ! Cartesian derivatives.
  94 !      common /dipmat/
  95       real(kind=8),dimension(:,:,:,:),allocatable :: a_chuj      !(2,2,maxconts,maxres)
  96       real(kind=8),dimension(:,:,:,:,:,:),allocatable :: a_chuj_der      !(2,2,3,5,maxconts,maxres)
  97 !      common /diploc/
  98       real(kind=8),dimension(2,2,2) :: AEA,AEAderg,EAEA,AECA,&
  99        AECAderg,ADtEA,ADtEA1,AEAb1,AEAb1derg,AEAb2
 100       real(kind=8),dimension(2,2,2,2) :: EAEAderg,ADtEAderg,&
 101        ADtEA1derg,AEAb2derg
 102       real(kind=8),dimension(2,2,3,5,2,2) :: AEAderx,EAEAderx,&
 103        AECAderx,ADtEAderx,ADtEA1derx
 104       real(kind=8),dimension(2,3,5,2,2,2) :: AEAb1derx,AEAb2derx
 105       real(kind=8),dimension(3,2) :: g_contij
 106       real(kind=8) :: ekont
 107 ! 12/13/2008 (again Poland-Jaruzel war anniversary)
 108 !   RE: Parallelization of 4th and higher order loc-el correlations
 109 !      common /contdistrib/
 110       integer,dimension(:),allocatable :: ncont_sent,ncont_recv !(maxres)
 111 ! ncont_sent,ncont_recv są w multibody_ello i multibody_hb
 112 !-----------------------------------------------------------------------------
 113 ! commom.deriv;
 114 !      common /derivat/
 115 !      real(kind=8),dimension(:,:),allocatable :: dcdv,dxdv !(6,maxdim)
 116 !      real(kind=8),dimension(:,:),allocatable :: dxds !(6,maxres)
 117 !      real(kind=8),dimension(:,:,:),allocatable :: gradx,gradc !(3,maxres,2)
 118       real(kind=8),dimension(:,:),allocatable :: gvdwc,gelc,gelc_long,&
 119         gvdwpp,gvdwc_scpp,gradx_scp,gvdwc_scp,ghpbx,ghpbc,&
 120         gradcorr,gradcorr_long,gradcorr5_long,gradcorr6_long,&
 121         gcorr6_turn_long,gradxorr,gradcorr5,gradcorr6,gliptran,gliptranc,&
 122         gliptranx, &
 123         gshieldx,gshieldc,gshieldc_loc,gshieldx_ec,&
 124         gshieldc_ec,gshieldc_loc_ec,gshieldx_t3, &
 125         gshieldc_t3,gshieldc_loc_t3,gshieldx_t4,gshieldc_t4, &
 126         gshieldc_loc_t4,gshieldx_ll,gshieldc_ll,gshieldc_loc_ll,&
 127         grad_shield,gg_tube,gg_tube_sc,gradafm !(3,maxres)
 128 !-----------------------------NUCLEIC GRADIENT
 129       real(kind=8),dimension(:,:),allocatable  ::gradb_nucl,gradbx_nucl, &
 130         gvdwpsb1,gelpp,gvdwpsb,gelsbc,gelsbx,gvdwsbx,gvdwsbc,gsbloc,&
 131         gsblocx,gradcorr_nucl,gradxorr_nucl,gradcorr3_nucl,gradxorr3_nucl,&
 132         gvdwpp_nucl
 133 !-----------------------------NUCLEIC-PROTEIN GRADIENT
 134       real(kind=8),dimension(:,:),allocatable  :: gvdwx_scbase,gvdwc_scbase,&
 135          gvdwx_pepbase,gvdwc_pepbase,gvdwx_scpho,gvdwc_scpho,&
 136          gvdwc_peppho
 137 !------------------------------IONS GRADIENT
 138         real(kind=8),dimension(:,:),allocatable  ::  gradcatcat, &
 139           gradpepcat,gradpepcatx
 140 !      real(kind=8),dimension(:,:),allocatable :: gloc,gloc_x !(maxvar,2)
 141
 142
 143       real(kind=8),dimension(:,:),allocatable :: gel_loc,gel_loc_long,&
 144         gcorr3_turn,gcorr4_turn,gcorr6_turn,gradb,gradbx !(3,maxres)
 145       real(kind=8),dimension(:),allocatable :: gel_loc_loc,&
 146         gel_loc_turn3,gel_loc_turn4,gel_loc_turn6,gcorr_loc,g_corr5_loc,&
 147         g_corr6_loc      !(maxvar)
 148       real(kind=8),dimension(:,:),allocatable :: gsccorc,gsccorx !(3,maxres)
 149       real(kind=8),dimension(:),allocatable :: gsccor_loc      !(maxres)
 150 !      real(kind=8),dimension(:,:,:),allocatable :: dtheta      !(3,2,maxres)
 151       real(kind=8),dimension(:,:),allocatable :: gscloc,gsclocx !(3,maxres)
 152 !      real(kind=8),dimension(:,:,:),allocatable :: dphi,dalpha,domega !(3,3,maxres)
 153       real(kind=8),dimension(:,:,:),allocatable :: grad_shield_side, &
 154          grad_shield_loc ! (3,maxcontsshileding,maxnres)
 155 !      integer :: nfl,icg
 156 !      common /deriv_loc/
 157       real(kind=8), dimension(:),allocatable :: fac_shield
 158       real(kind=8),dimension(3,5,2) :: derx,derx_turn
 159 !      common /deriv_scloc/
 160       real(kind=8),dimension(:,:),allocatable :: dXX_C1tab,dYY_C1tab,&
 161        dZZ_C1tab,dXX_Ctab,dYY_Ctab,dZZ_Ctab,dXX_XYZtab,dYY_XYZtab,&
 162        dZZ_XYZtab      !(3,maxres)
 163 !-----------------------------------------------------------------------------
 164 ! common.maxgrad
 165 !      common /maxgrad/
 166       real(kind=8) :: gvdwc_max,gvdwc_scp_max,gelc_max,gvdwpp_max,&
 167        gradb_max,ghpbc_max,&
 168        gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
 169        gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
 170        gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
 171        gsccorx_max,gsclocx_max
 172 !-----------------------------------------------------------------------------
 173 ! common.MD
 174 !      common /back_constr/
 175       real(kind=8),dimension(:),allocatable :: dutheta,dugamma !(maxres)
 176       real(kind=8),dimension(:,:),allocatable :: duscdiff,duscdiffx !(3,maxres)
 177 !      common /qmeas/
 178       real(kind=8) :: Ucdfrag,Ucdpair
 179       real(kind=8),dimension(:,:),allocatable :: dUdconst,dUdxconst,&
 180        dqwol,dxqwol      !(3,0:MAXRES)
 181 !-----------------------------------------------------------------------------
 182 ! common.sbridge
 183 !      common /dyn_ssbond/
 184       real(kind=8),dimension(:,:),allocatable :: dyn_ssbond_ij !(maxres,maxres)
 185 !-----------------------------------------------------------------------------
 186 ! common.sccor
 187 ! Parameters of the SCCOR term
 188 !      common/sccor/
 189       real(kind=8),dimension(:,:,:,:),allocatable :: dcostau,dsintau,&
 190        dcosomicron,domicron      !(3,3,3,maxres2)
 191 !-----------------------------------------------------------------------------
 192 ! common.vectors
 193 !      common /vectors/
 194       real(kind=8),dimension(:,:),allocatable :: uy,uz !(3,maxres)
 195       real(kind=8),dimension(:,:,:,:),allocatable :: uygrad,uzgrad !(3,3,2,maxres)
 196 !-----------------------------------------------------------------------------
 197 ! common /przechowalnia/
 198       real(kind=8),dimension(:,:,:),allocatable :: zapas
 199       real(kind=8),dimension(:,:,:,:),allocatable ::zapas2 !(max_dim,maxconts,max_fg_procs)
 200       real(kind=8),dimension(:,:,:),allocatable :: fromto !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
 201 !-----------------------------------------------------------------------------
 202 !-----------------------------------------------------------------------------
 203 !
 204 !
 205 !-----------------------------------------------------------------------------
 206       contains
 207 !-----------------------------------------------------------------------------
 208 ! energy_p_new_barrier.F
 209 !-----------------------------------------------------------------------------
 210       subroutine etotal(energia)
 211 !      implicit real*8 (a-h,o-z)
 212 !      include 'DIMENSIONS'
 213       use MD_data
 214 #ifndef ISNAN
 215       external proc_proc
 216 #ifdef WINPGI
 217 !MS$ATTRIBUTES C ::  proc_proc
 218 #endif
 219 #endif
 220 #ifdef MPI
 221       include "mpif.h"
 222 #endif
 223 !      include 'COMMON.SETUP'
 224 !      include 'COMMON.IOUNITS'
 225       real(kind=8),dimension(0:n_ene) :: energia
 226 !      include 'COMMON.LOCAL'
 227 !      include 'COMMON.FFIELD'
 228 !      include 'COMMON.DERIV'
 229 !      include 'COMMON.INTERACT'
 230 !      include 'COMMON.SBRIDGE'
 231 !      include 'COMMON.CHAIN'
 232 !      include 'COMMON.VAR'
 233 !      include 'COMMON.MD'
 234 !      include 'COMMON.CONTROL'
 235 !      include 'COMMON.TIME1'
 236       real(kind=8) :: time00
 237 !el local variables
 238       integer :: n_corr,n_corr1,ierror
 239       real(kind=8) :: etors,edihcnstr,etors_d,esccor,ehpb
 240       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,escloc,ees,eel_loc
 241       real(kind=8) :: eello_turn3,eello_turn4,estr,ebe,eliptran,etube, &
 242                       Eafmforce,ethetacnstr
 243       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
 244 ! now energies for nulceic alone parameters
 245       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 246                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 247                       ecorr3_nucl
 248 ! energies for ions
 249       real(kind=8) :: ecation_prot,ecationcation
 250 ! energies for protein nucleic acid interaction
 251       real(kind=8) :: escbase,epepbase,escpho,epeppho
 252
 253 #ifdef MPI
 254       real(kind=8) :: weights_(n_ene) !,time_Bcast,time_Bcastw
 255 ! shielding effect varibles for MPI
 256       real(kind=8)   fac_shieldbuf(nres), &
 257       grad_shield_locbuf(3,maxcontsshi,-1:nres), &
 258       grad_shield_sidebuf(3,maxcontsshi,-1:nres), &
 259       grad_shieldbuf(3,-1:nres)
 260        integer ishield_listbuf(-1:nres), &
 261        shield_listbuf(maxcontsshi,-1:nres),k,j,i
 262
 263 !      real(kind=8),  dimension(:),allocatable::  fac_shieldbuf
 264 !      real(kind=8), dimension(:,:,:),allocatable:: &
 265 !       grad_shield_locbuf,grad_shield_sidebuf
 266 !      real(kind=8), dimension(:,:),allocatable:: &
 267 !        grad_shieldbuf
 268 !       integer, dimension(:),allocatable:: &
 269 !       ishield_listbuf
 270 !       integer, dimension(:,:),allocatable::  shield_listbuf
 271 !       integer :: k,j,i
 272 !      if (.not.allocated(fac_shieldbuf)) then
 273 !          allocate(fac_shieldbuf(nres))
 274 !          allocate(grad_shield_locbuf(3,maxcontsshi,-1:nres))
 275 !          allocate(grad_shield_sidebuf(3,maxcontsshi,-1:nres))
 276 !          allocate(grad_shieldbuf(3,-1:nres))
 277 !          allocate(ishield_listbuf(nres))
 278 !          allocate(shield_listbuf(maxcontsshi,nres))
 279 !       endif
 280
 281 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 282 !     & " nfgtasks",nfgtasks
 283       if (nfgtasks.gt.1) then
 284         time00=MPI_Wtime()
 285 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 286         if (fg_rank.eq.0) then
 287           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 288 !          print *,"Processor",myrank," BROADCAST iorder"
 289 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 290 ! FG slaves as WEIGHTS array.
 291          ! weights_(1)=wsc
 292           weights_(2)=wscp
 293           weights_(3)=welec
 294           weights_(4)=wcorr
 295           weights_(5)=wcorr5
 296           weights_(6)=wcorr6
 297           weights_(7)=wel_loc
 298           weights_(8)=wturn3
 299           weights_(9)=wturn4
 300           weights_(10)=wturn6
 301           weights_(11)=wang
 302           weights_(12)=wscloc
 303           weights_(13)=wtor
 304           weights_(14)=wtor_d
 305           weights_(15)=wstrain
 306           weights_(16)=wvdwpp
 307           weights_(17)=wbond
 308           weights_(18)=scal14
 309           weights_(21)=wsccor
 310           weights_(26)=wvdwpp_nucl
 311           weights_(27)=welpp
 312           weights_(28)=wvdwpsb
 313           weights_(29)=welpsb
 314           weights_(30)=wvdwsb
 315           weights_(31)=welsb
 316           weights_(32)=wbond_nucl
 317           weights_(33)=wang_nucl
 318           weights_(34)=wsbloc
 319           weights_(35)=wtor_nucl
 320           weights_(36)=wtor_d_nucl
 321           weights_(37)=wcorr_nucl
 322           weights_(38)=wcorr3_nucl
 323           weights_(41)=wcatcat
 324           weights_(42)=wcatprot
 325           weights_(46)=wscbase
 326           weights_(47)=wscpho
 327           weights_(48)=wpeppho
 328 !          wcatcat= weights(41)
 329 !          wcatprot=weights(42)
 330
 331 ! FG Master broadcasts the WEIGHTS_ array
 332           call MPI_Bcast(weights_(1),n_ene,&
 333              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 334         else
 335 ! FG slaves receive the WEIGHTS array
 336           call MPI_Bcast(weights(1),n_ene,&
 337               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 338           wsc=weights(1)
 339           wscp=weights(2)
 340           welec=weights(3)
 341           wcorr=weights(4)
 342           wcorr5=weights(5)
 343           wcorr6=weights(6)
 344           wel_loc=weights(7)
 345           wturn3=weights(8)
 346           wturn4=weights(9)
 347           wturn6=weights(10)
 348           wang=weights(11)
 349           wscloc=weights(12)
 350           wtor=weights(13)
 351           wtor_d=weights(14)
 352           wstrain=weights(15)
 353           wvdwpp=weights(16)
 354           wbond=weights(17)
 355           scal14=weights(18)
 356           wsccor=weights(21)
 357           wvdwpp_nucl =weights(26)
 358           welpp  =weights(27)
 359           wvdwpsb=weights(28)
 360           welpsb =weights(29)
 361           wvdwsb =weights(30)
 362           welsb  =weights(31)
 363           wbond_nucl  =weights(32)
 364           wang_nucl   =weights(33)
 365           wsbloc =weights(34)
 366           wtor_nucl   =weights(35)
 367           wtor_d_nucl =weights(36)
 368           wcorr_nucl  =weights(37)
 369           wcorr3_nucl =weights(38)
 370           wcatcat= weights(41)
 371           wcatprot=weights(42)
 372           wscbase=weights(46)
 373           wscpho=weights(47)
 374           wpeppho=weights(48)
 375         endif
 376         time_Bcast=time_Bcast+MPI_Wtime()-time00
 377         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 378 !        call chainbuild_cart
 379       endif
 380 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 381 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 382 #else
 383 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 384 !        call int_from_cart1(.false.)
 385 !      endif
 386 #endif
 387 #ifdef TIMING
 388       time00=MPI_Wtime()
 389 #endif
 390 !
 391 ! Compute the side-chain and electrostatic interaction energy
 392 !        print *, "Before EVDW"
 393 !      goto (101,102,103,104,105,106) ipot
 394       select case(ipot)
 395 ! Lennard-Jones potential.
 396 !  101 call elj(evdw)
 397        case (1)
 398          call elj(evdw)
 399 !d    print '(a)','Exit ELJcall el'
 400 !      goto 107
 401 ! Lennard-Jones-Kihara potential (shifted).
 402 !  102 call eljk(evdw)
 403        case (2)
 404          call eljk(evdw)
 405 !      goto 107
 406 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 407 !  103 call ebp(evdw)
 408        case (3)
 409          call ebp(evdw)
 410 !      goto 107
 411 ! Gay-Berne potential (shifted LJ, angular dependence).
 412 !  104 call egb(evdw)
 413        case (4)
 414 !       print *,"MOMO",scelemode
 415         if (scelemode.eq.0) then
 416          call egb(evdw)
 417         else
 418          call emomo(evdw)
 419         endif
 420 !      goto 107
 421 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 422 !  105 call egbv(evdw)
 423        case (5)
 424          call egbv(evdw)
 425 !      goto 107
 426 ! Soft-sphere potential
 427 !  106 call e_softsphere(evdw)
 428        case (6)
 429          call e_softsphere(evdw)
 430 !
 431 ! Calculate electrostatic (H-bonding) energy of the main chain.
 432 !
 433 !  107 continue
 434        case default
 435          write(iout,*)"Wrong ipot"
 436 !         return
 437 !   50 continue
 438       end select
 439 !      continue
 440 !        print *,"after EGB"
 441 ! shielding effect
 442        if (shield_mode.eq.2) then
 443                  call set_shield_fac2
 444
 445       if (nfgtasks.gt.1) then
 446 !#define DEBUG
 447 #ifdef DEBUG
 448        write(iout,*) "befor reduce fac_shield reduce"
 449        do i=1,nres
 450         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 451         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 452        grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 453        enddo
 454 #endif
 455         do i=1,nres
 456         ishield_listbuf(i)=0
 457 !        fac_shieldbuf(i)=0.0d0
 458         enddo
 459         call MPI_Allgatherv(fac_shield(ivec_start), &
 460         ivec_count(fg_rank1), &
 461         MPI_DOUBLE_PRECISION,fac_shieldbuf(1),ivec_count(0), &
 462         ivec_displ(0), &
 463         MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 464         call MPI_Allgatherv(shield_list(1,ivec_start), &
 465         ivec_count(fg_rank1), &
 466         MPI_I50,shield_listbuf(1,1),ivec_count(0), &
 467         ivec_displ(0), &
 468         MPI_I50,FG_COMM,IERROR)
 469 !        write(2,*) "After I50"
 470 !        call flush(iout)
 471         call MPI_Allgatherv(ishield_list(ivec_start), &
 472         ivec_count(fg_rank1), &
 473         MPI_INTEGER,ishield_listbuf(1),ivec_count(0), &
 474         ivec_displ(0), &
 475         MPI_INTEGER,FG_COMM,IERROR)
 476
 477         call MPI_Allgatherv(grad_shield(1,ivec_start), &
 478         ivec_count(fg_rank1), &
 479         MPI_D50,grad_shieldbuf(1,1),ivec_count(0), &
 480         ivec_displ(0), &
 481         MPI_D50,FG_COMM,IERROR)
 482         call MPI_Allgatherv(grad_shield_side(1,1,ivec_start), &
 483         ivec_count(fg_rank1), &
 484         MPI_SHI,grad_shield_sidebuf(1,1,1),ivec_count(0), &
 485         ivec_displ(0), &
 486         MPI_SHI,FG_COMM,IERROR)
 487         call MPI_Allgatherv(grad_shield_loc(1,1,ivec_start), &
 488         ivec_count(fg_rank1), &
 489         MPI_SHI,grad_shield_locbuf(1,1,1),ivec_count(0), &
 490         ivec_displ(0), &
 491         MPI_SHI,FG_COMM,IERROR)
 492 !        write(2,*) "After MPI_SHI"
 493         call flush(iout)
 494
 495         do i=1,nres
 496          fac_shield(i)=fac_shieldbuf(i)
 497          ishield_list(i)=ishield_listbuf(i)
 498 !         write(iout,*) i,fac_shield(i)
 499          do j=1,3
 500          grad_shield(j,i)=grad_shieldbuf(j,i)
 501          enddo !j
 502          do j=1,ishield_list(i)
 503           write (iout,*) "ishild", ishield_list(i),i
 504            shield_list(j,i)=shield_listbuf(j,i)
 505           do k=1,3
 506           grad_shield_loc(k,j,i)=grad_shield_locbuf(k,j,i)
 507           grad_shield_side(k,j,i)=grad_shield_sidebuf(k,j,i)
 508           enddo !k
 509         enddo !j
 510        enddo !i
 511        endif
 512 #ifdef DEBUG
 513        write(iout,*) "after reduce fac_shield reduce"
 514        do i=1,nres
 515         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 516         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 517         grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 518        enddo
 519 #endif
 520 !#undef DEBUG
 521        endif
 522
 523
 524
 525 !       print *,"AFTER EGB",ipot,evdw
 526 !mc
 527 !mc Sep-06: egb takes care of dynamic ss bonds too
 528 !mc
 529 !      if (dyn_ss) call dyn_set_nss
 530 !      print *,"Processor",myrank," computed USCSC"
 531 #ifdef TIMING
 532       time01=MPI_Wtime()
 533 #endif
 534       call vec_and_deriv
 535 #ifdef TIMING
 536       time_vec=time_vec+MPI_Wtime()-time01
 537 #endif
 538
 539
 540
 541
 542 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 543       if (ipot.lt.6) then
 544 #ifdef SPLITELE
 545 !         print *,"after ipot if", ipot
 546          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 547              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 548              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 549              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 550 #else
 551          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 552              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 553              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 554              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 555 #endif
 556             write(iout,*),"just befor eelec call"
 557             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 558          write (iout,*) "ELEC calc"
 559          else
 560             ees=0.0d0
 561             evdw1=0.0d0
 562             eel_loc=0.0d0
 563             eello_turn3=0.0d0
 564             eello_turn4=0.0d0
 565          endif
 566       else
 567 !        write (iout,*) "Soft-spheer ELEC potential"
 568         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 569          eello_turn4)
 570       endif
 571 !      print *,"Processor",myrank," computed UELEC"
 572 !
 573 ! Calculate excluded-volume interaction energy between peptide groups
 574 ! and side chains.
 575 !
 576        write(iout,*) "in etotal calc exc;luded",ipot
 577
 578       if (ipot.lt.6) then
 579        if(wscp.gt.0d0) then
 580         call escp(evdw2,evdw2_14)
 581        else
 582         evdw2=0
 583         evdw2_14=0
 584        endif
 585       else
 586 !        write (iout,*) "Soft-sphere SCP potential"
 587         call escp_soft_sphere(evdw2,evdw2_14)
 588       endif
 589         write(iout,*) "in etotal before ebond",ipot
 590
 591 !
 592 ! Calculate the bond-stretching energy
 593 !
 594       call ebond(estr)
 595 !       print *,"EBOND",estr
 596        write(iout,*) "in etotal afer ebond",ipot
 597
 598 !
 599 ! Calculate the disulfide-bridge and other energy and the contributions
 600 ! from other distance constraints.
 601 !      print *,'Calling EHPB'
 602       call edis(ehpb)
 603 !elwrite(iout,*) "in etotal afer edis",ipot
 604 !      print *,'EHPB exitted succesfully.'
 605 !
 606 ! Calculate the virtual-bond-angle energy.
 607 !
 608       if (wang.gt.0d0) then
 609         call ebend(ebe,ethetacnstr)
 610       else
 611         ebe=0
 612         ethetacnstr=0
 613       endif
 614 !      print *,"Processor",myrank," computed UB"
 615 !
 616 ! Calculate the SC local energy.
 617 !
 618       call esc(escloc)
 619 !elwrite(iout,*) "in etotal afer esc",ipot
 620 !      print *,"Processor",myrank," computed USC"
 621 !
 622 ! Calculate the virtual-bond torsional energy.
 623 !
 624 !d    print *,'nterm=',nterm
 625       if (wtor.gt.0) then
 626        call etor(etors,edihcnstr)
 627       else
 628        etors=0
 629        edihcnstr=0
 630       endif
 631 !      print *,"Processor",myrank," computed Utor"
 632
 633 !
 634 ! 6/23/01 Calculate double-torsional energy
 635 !
 636 !elwrite(iout,*) "in etotal",ipot
 637       if (wtor_d.gt.0) then
 638        call etor_d(etors_d)
 639       else
 640        etors_d=0
 641       endif
 642 !      print *,"Processor",myrank," computed Utord"
 643 !
 644 ! 21/5/07 Calculate local sicdechain correlation energy
 645 !
 646       if (wsccor.gt.0.0d0) then
 647         call eback_sc_corr(esccor)
 648       else
 649         esccor=0.0d0
 650       endif
 651
 652       write(iout,*) "before multibody"
 653 !      print *,"Processor",myrank," computed Usccorr"
 654 !
 655 ! 12/1/95 Multi-body terms
 656 !
 657       n_corr=0
 658       n_corr1=0
 659       call flush(iout)
 660       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 661           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 662          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 663 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 664 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 665       else
 666          ecorr=0.0d0
 667          ecorr5=0.0d0
 668          ecorr6=0.0d0
 669          eturn6=0.0d0
 670       endif
 671 !elwrite(iout,*) "in etotal",ipot
 672       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 673          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 674 !d         write (iout,*) "multibody_hb ecorr",ecorr
 675       endif
 676       write(iout,*) "afeter  multibody hb"
 677
 678 !      print *,"Processor",myrank," computed Ucorr"
 679 !
 680 ! If performing constraint dynamics, call the constraint energy
 681 !  after the equilibration time
 682       if(usampl.and.totT.gt.eq_time) then
 683 !elwrite(iout,*) "afeter  multibody hb"
 684          call EconstrQ
 685 !elwrite(iout,*) "afeter  multibody hb"
 686          call Econstr_back
 687 !elwrite(iout,*) "afeter  multibody hb"
 688       else
 689          Uconst=0.0d0
 690          Uconst_back=0.0d0
 691       endif
 692       call flush(iout)
 693          write(iout,*) "after Econstr"
 694
 695       if (wliptran.gt.0) then
 696 !        print *,"PRZED WYWOLANIEM"
 697         call Eliptransfer(eliptran)
 698       else
 699        eliptran=0.0d0
 700       endif
 701       if (fg_rank.eq.0) then
 702       if (AFMlog.gt.0) then
 703         call AFMforce(Eafmforce)
 704       else if (selfguide.gt.0) then
 705         call AFMvel(Eafmforce)
 706       endif
 707       endif
 708       if (tubemode.eq.1) then
 709        call calctube(etube)
 710       else if (tubemode.eq.2) then
 711        call calctube2(etube)
 712       elseif (tubemode.eq.3) then
 713        call calcnano(etube)
 714       else
 715        etube=0.0d0
 716       endif
 717 !--------------------------------------------------------
 718        write (iout,*) "NRES_MOLEC(2),",nres_molec(2)
 719 !      print *,"before",ees,evdw1,ecorr
 720 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 721       if (nres_molec(2).gt.0) then
 722       call ebond_nucl(estr_nucl)
 723       call ebend_nucl(ebe_nucl)
 724       call etor_nucl(etors_nucl)
 725       call esb_gb(evdwsb,eelsb)
 726       call epp_nucl_sub(evdwpp,eespp)
 727       call epsb(evdwpsb,eelpsb)
 728       call esb(esbloc)
 729 !      call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 730       else
 731        etors_nucl=0.0d0
 732        estr_nucl=0.0d0
 733        ecorr3_nucl=0.0d0
 734        ebe_nucl=0.0d0
 735        evdwsb=0.0d0
 736        eelsb=0.0d0
 737        esbloc=0.0d0
 738        evdwpsb=0.0d0
 739        eelpsb=0.0d0
 740        evdwpp=0.0d0
 741        eespp=0.0d0
 742       endif
 743 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 744       if (nfgtasks.gt.1) then
 745       if (fg_rank.eq.0) then
 746       call ecatcat(ecationcation)
 747       endif
 748       else
 749       call ecatcat(ecationcation)
 750       endif
 751       call ecat_prot(ecation_prot)
 752       if (nres_molec(2).gt.0) then
 753       call eprot_sc_base(escbase)
 754       call epep_sc_base(epepbase)
 755       call eprot_sc_phosphate(escpho)
 756       call eprot_pep_phosphate(epeppho)
 757       else
 758       epepbase=0.0
 759       escbase=0.0
 760       escpho=0.0
 761       epeppho=0.0
 762       endif
 763 !      call ecatcat(ecationcation)
 764 !      print *,"after ebend", ebe_nucl
 765 #ifdef TIMING
 766       time_enecalc=time_enecalc+MPI_Wtime()-time00
 767 #endif
 768 !      print *,"Processor",myrank," computed Uconstr"
 769 #ifdef TIMING
 770       time00=MPI_Wtime()
 771 #endif
 772 !
 773 ! Sum the energies
 774 !
 775       energia(1)=evdw
 776 #ifdef SCP14
 777       energia(2)=evdw2-evdw2_14
 778       energia(18)=evdw2_14
 779 #else
 780       energia(2)=evdw2
 781       energia(18)=0.0d0
 782 #endif
 783 #ifdef SPLITELE
 784       energia(3)=ees
 785       energia(16)=evdw1
 786 #else
 787       energia(3)=ees+evdw1
 788       energia(16)=0.0d0
 789 #endif
 790       energia(4)=ecorr
 791       energia(5)=ecorr5
 792       energia(6)=ecorr6
 793       energia(7)=eel_loc
 794       energia(8)=eello_turn3
 795       energia(9)=eello_turn4
 796       energia(10)=eturn6
 797       energia(11)=ebe
 798       energia(12)=escloc
 799       energia(13)=etors
 800       energia(14)=etors_d
 801       energia(15)=ehpb
 802       energia(19)=edihcnstr
 803       energia(17)=estr
 804       energia(20)=Uconst+Uconst_back
 805       energia(21)=esccor
 806       energia(22)=eliptran
 807       energia(23)=Eafmforce
 808       energia(24)=ethetacnstr
 809       energia(25)=etube
 810 !---------------------------------------------------------------
 811       energia(26)=evdwpp
 812       energia(27)=eespp
 813       energia(28)=evdwpsb
 814       energia(29)=eelpsb
 815       energia(30)=evdwsb
 816       energia(31)=eelsb
 817       energia(32)=estr_nucl
 818       energia(33)=ebe_nucl
 819       energia(34)=esbloc
 820       energia(35)=etors_nucl
 821       energia(36)=etors_d_nucl
 822       energia(37)=ecorr_nucl
 823       energia(38)=ecorr3_nucl
 824 !----------------------------------------------------------------------
 825 !    Here are the energies showed per procesor if the are more processors
 826 !    per molecule then we sum it up in sum_energy subroutine
 827 !      print *," Processor",myrank," calls SUM_ENERGY"
 828       energia(41)=ecation_prot
 829       energia(42)=ecationcation
 830       energia(46)=escbase
 831       energia(47)=epepbase
 832       energia(48)=escpho
 833       energia(49)=epeppho
 834       call sum_energy(energia,.true.)
 835       if (dyn_ss) call dyn_set_nss
 836 !      print *," Processor",myrank," left SUM_ENERGY"
 837 #ifdef TIMING
 838       time_sumene=time_sumene+MPI_Wtime()-time00
 839 #endif
 840         call enerprint(energia)
 841 !elwrite(iout,*)"finish etotal"
 842       return
 843       end subroutine etotal
 844 !-----------------------------------------------------------------------------
 845       subroutine sum_energy(energia,reduce)
 846 !      implicit real*8 (a-h,o-z)
 847 !      include 'DIMENSIONS'
 848 #ifndef ISNAN
 849       external proc_proc
 850 #ifdef WINPGI
 851 !MS$ATTRIBUTES C ::  proc_proc
 852 #endif
 853 #endif
 854 #ifdef MPI
 855       include "mpif.h"
 856 #endif
 857 !      include 'COMMON.SETUP'
 858 !      include 'COMMON.IOUNITS'
 859       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 860 !      include 'COMMON.FFIELD'
 861 !      include 'COMMON.DERIV'
 862 !      include 'COMMON.INTERACT'
 863 !      include 'COMMON.SBRIDGE'
 864 !      include 'COMMON.CHAIN'
 865 !      include 'COMMON.VAR'
 866 !      include 'COMMON.CONTROL'
 867 !      include 'COMMON.TIME1'
 868       logical :: reduce
 869       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 870       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 871       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 872         eliptran,etube, Eafmforce,ethetacnstr
 873       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 874                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 875                       ecorr3_nucl
 876       real(kind=8) :: ecation_prot,ecationcation
 877       real(kind=8) :: escbase,epepbase,escpho,epeppho
 878       integer :: i
 879 #ifdef MPI
 880       integer :: ierr
 881       real(kind=8) :: time00
 882       if (nfgtasks.gt.1 .and. reduce) then
 883
 884 #ifdef DEBUG
 885         write (iout,*) "energies before REDUCE"
 886         call enerprint(energia)
 887         call flush(iout)
 888 #endif
 889         do i=0,n_ene
 890           enebuff(i)=energia(i)
 891         enddo
 892         time00=MPI_Wtime()
 893         call MPI_Barrier(FG_COMM,IERR)
 894         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 895         time00=MPI_Wtime()
 896         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 897           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 898 #ifdef DEBUG
 899         write (iout,*) "energies after REDUCE"
 900         call enerprint(energia)
 901         call flush(iout)
 902 #endif
 903         time_Reduce=time_Reduce+MPI_Wtime()-time00
 904       endif
 905       if (fg_rank.eq.0) then
 906 #endif
 907       evdw=energia(1)
 908 #ifdef SCP14
 909       evdw2=energia(2)+energia(18)
 910       evdw2_14=energia(18)
 911 #else
 912       evdw2=energia(2)
 913 #endif
 914 #ifdef SPLITELE
 915       ees=energia(3)
 916       evdw1=energia(16)
 917 #else
 918       ees=energia(3)
 919       evdw1=0.0d0
 920 #endif
 921       ecorr=energia(4)
 922       ecorr5=energia(5)
 923       ecorr6=energia(6)
 924       eel_loc=energia(7)
 925       eello_turn3=energia(8)
 926       eello_turn4=energia(9)
 927       eturn6=energia(10)
 928       ebe=energia(11)
 929       escloc=energia(12)
 930       etors=energia(13)
 931       etors_d=energia(14)
 932       ehpb=energia(15)
 933       edihcnstr=energia(19)
 934       estr=energia(17)
 935       Uconst=energia(20)
 936       esccor=energia(21)
 937       eliptran=energia(22)
 938       Eafmforce=energia(23)
 939       ethetacnstr=energia(24)
 940       etube=energia(25)
 941       evdwpp=energia(26)
 942       eespp=energia(27)
 943       evdwpsb=energia(28)
 944       eelpsb=energia(29)
 945       evdwsb=energia(30)
 946       eelsb=energia(31)
 947       estr_nucl=energia(32)
 948       ebe_nucl=energia(33)
 949       esbloc=energia(34)
 950       etors_nucl=energia(35)
 951       etors_d_nucl=energia(36)
 952       ecorr_nucl=energia(37)
 953       ecorr3_nucl=energia(38)
 954       ecation_prot=energia(41)
 955       ecationcation=energia(42)
 956       escbase=energia(46)
 957       epepbase=energia(47)
 958       escpho=energia(48)
 959       epeppho=energia(49)
 960 !      energia(41)=ecation_prot
 961 !      energia(42)=ecationcation
 962
 963
 964 #ifdef SPLITELE
 965       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 966        +wang*ebe+wtor*etors+wscloc*escloc &
 967        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 968        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 969        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 970        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 971        +Eafmforce+ethetacnstr  &
 972        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 973        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 974        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 975        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
 976        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
 977        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
 978 #else
 979       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 980        +wang*ebe+wtor*etors+wscloc*escloc &
 981        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 982        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 983        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 984        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 985        +Eafmforce+ethetacnstr &
 986        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 987        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 988        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 989        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
 990        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
 991        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
 992 #endif
 993       energia(0)=etot
 994 ! detecting NaNQ
 995 #ifdef ISNAN
 996 #ifdef AIX
 997       if (isnan(etot).ne.0) energia(0)=1.0d+99
 998 #else
 999       if (isnan(etot)) energia(0)=1.0d+99
1000 #endif
1001 #else
1002       i=0
1003 #ifdef WINPGI
1004       idumm=proc_proc(etot,i)
1005 #else
1006       call proc_proc(etot,i)
1007 #endif
1008       if(i.eq.1)energia(0)=1.0d+99
1009 #endif
1010 #ifdef MPI
1011       endif
1012 #endif
1013 !      call enerprint(energia)
1014       call flush(iout)
1015       return
1016       end subroutine sum_energy
1017 !-----------------------------------------------------------------------------
1018       subroutine rescale_weights(t_bath)
1019 !      implicit real*8 (a-h,o-z)
1020 #ifdef MPI
1021       include 'mpif.h'
1022 #endif
1023 !      include 'DIMENSIONS'
1024 !      include 'COMMON.IOUNITS'
1025 !      include 'COMMON.FFIELD'
1026 !      include 'COMMON.SBRIDGE'
1027       real(kind=8) :: kfac=2.4d0
1028       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
1029 !el local variables
1030       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
1031       real(kind=8) :: T0=3.0d2
1032       integer :: ierror
1033 !      facT=temp0/t_bath
1034 !      facT=2*temp0/(t_bath+temp0)
1035       if (rescale_mode.eq.0) then
1036         facT(1)=1.0d0
1037         facT(2)=1.0d0
1038         facT(3)=1.0d0
1039         facT(4)=1.0d0
1040         facT(5)=1.0d0
1041         facT(6)=1.0d0
1042       else if (rescale_mode.eq.1) then
1043         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
1044         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1045         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1046         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1047         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1048 #ifdef WHAM_RUN
1049 !#if defined(WHAM_RUN) || defined(CLUSTER)
1050 #if defined(FUNCTH)
1051 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
1052         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1053 #elif defined(FUNCT)
1054         facT(6)=t_bath/T0
1055 #else
1056         facT(6)=1.0d0
1057 #endif
1058 #endif
1059       else if (rescale_mode.eq.2) then
1060         x=t_bath/temp0
1061         x2=x*x
1062         x3=x2*x
1063         x4=x3*x
1064         x5=x4*x
1065         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
1066         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
1067         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
1068         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
1069         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
1070 #ifdef WHAM_RUN
1071 !#if defined(WHAM_RUN) || defined(CLUSTER)
1072 #if defined(FUNCTH)
1073         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1074 #elif defined(FUNCT)
1075         facT(6)=t_bath/T0
1076 #else
1077         facT(6)=1.0d0
1078 #endif
1079 #endif
1080       else
1081         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1082         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1083 #ifdef MPI
1084        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1085 #endif
1086        stop 555
1087       endif
1088       welec=weights(3)*fact(1)
1089       wcorr=weights(4)*fact(3)
1090       wcorr5=weights(5)*fact(4)
1091       wcorr6=weights(6)*fact(5)
1092       wel_loc=weights(7)*fact(2)
1093       wturn3=weights(8)*fact(2)
1094       wturn4=weights(9)*fact(3)
1095       wturn6=weights(10)*fact(5)
1096       wtor=weights(13)*fact(1)
1097       wtor_d=weights(14)*fact(2)
1098       wsccor=weights(21)*fact(1)
1099
1100       return
1101       end subroutine rescale_weights
1102 !-----------------------------------------------------------------------------
1103       subroutine enerprint(energia)
1104 !      implicit real*8 (a-h,o-z)
1105 !      include 'DIMENSIONS'
1106 !      include 'COMMON.IOUNITS'
1107 !      include 'COMMON.FFIELD'
1108 !      include 'COMMON.SBRIDGE'
1109 !      include 'COMMON.MD'
1110       real(kind=8) :: energia(0:n_ene)
1111 !el local variables
1112       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
1113       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
1114       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
1115        etube,ethetacnstr,Eafmforce
1116       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1117                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1118                       ecorr3_nucl
1119       real(kind=8) :: ecation_prot,ecationcation
1120       real(kind=8) :: escbase,epepbase,escpho,epeppho
1121
1122       etot=energia(0)
1123       evdw=energia(1)
1124       evdw2=energia(2)
1125 #ifdef SCP14
1126       evdw2=energia(2)+energia(18)
1127 #else
1128       evdw2=energia(2)
1129 #endif
1130       ees=energia(3)
1131 #ifdef SPLITELE
1132       evdw1=energia(16)
1133 #endif
1134       ecorr=energia(4)
1135       ecorr5=energia(5)
1136       ecorr6=energia(6)
1137       eel_loc=energia(7)
1138       eello_turn3=energia(8)
1139       eello_turn4=energia(9)
1140       eello_turn6=energia(10)
1141       ebe=energia(11)
1142       escloc=energia(12)
1143       etors=energia(13)
1144       etors_d=energia(14)
1145       ehpb=energia(15)
1146       edihcnstr=energia(19)
1147       estr=energia(17)
1148       Uconst=energia(20)
1149       esccor=energia(21)
1150       eliptran=energia(22)
1151       Eafmforce=energia(23)
1152       ethetacnstr=energia(24)
1153       etube=energia(25)
1154       evdwpp=energia(26)
1155       eespp=energia(27)
1156       evdwpsb=energia(28)
1157       eelpsb=energia(29)
1158       evdwsb=energia(30)
1159       eelsb=energia(31)
1160       estr_nucl=energia(32)
1161       ebe_nucl=energia(33)
1162       esbloc=energia(34)
1163       etors_nucl=energia(35)
1164       etors_d_nucl=energia(36)
1165       ecorr_nucl=energia(37)
1166       ecorr3_nucl=energia(38)
1167       ecation_prot=energia(41)
1168       ecationcation=energia(42)
1169       escbase=energia(46)
1170       epepbase=energia(47)
1171       escpho=energia(48)
1172       epeppho=energia(49)
1173 #ifdef SPLITELE
1174       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1175         estr,wbond,ebe,wang,&
1176         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1177         ecorr,wcorr,&
1178         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1179         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1180         edihcnstr,ethetacnstr,ebr*nss,&
1181         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1182         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1183         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1184         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1185         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1186         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1187         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1188         etot
1189    10 format (/'Virtual-chain energies:'// &
1190        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1191        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1192        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1193        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1194        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1195        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1196        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1197        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1198        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1199        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1200        ' (SS bridges & dist. cnstr.)'/ &
1201        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1202        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1203        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1204        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1205        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1206        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1207        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1208        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1209        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1210        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1211        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1212        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1213        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1214        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1215        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1216        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1217        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1218        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1219        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1220        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1221        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1222        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1223        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1224        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1225        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1226        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1227        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1228        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1229        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1230        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1231        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1232        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1233        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1234        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1235        'ETOT=  ',1pE16.6,' (total)')
1236 #else
1237       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1238         estr,wbond,ebe,wang,&
1239         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1240         ecorr,wcorr,&
1241         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1242         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1243         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,     &
1244         etube,wtube, &
1245         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1246         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb&
1247         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl&
1248         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1249         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1250         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1251         etot
1252    10 format (/'Virtual-chain energies:'// &
1253        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1254        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1255        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1256        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1257        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1258        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1259        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1260        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1261        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1262        ' (SS bridges & dist. cnstr.)'/ &
1263        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1264        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1265        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1266        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1267        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1268        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1269        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1270        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1271        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1272        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1273        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1274        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1275        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1276        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1277        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1278        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1279        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1280        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1281        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1282        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1283        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1284        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1285        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1286        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1287        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1288        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1289        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1290        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1291        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1292        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1293        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1294        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1295        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1296        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1297        'ETOT=  ',1pE16.6,' (total)')
1298 #endif
1299       return
1300       end subroutine enerprint
1301 !-----------------------------------------------------------------------------
1302       subroutine elj(evdw)
1303 !
1304 ! This subroutine calculates the interaction energy of nonbonded side chains
1305 ! assuming the LJ potential of interaction.
1306 !
1307 !      implicit real*8 (a-h,o-z)
1308 !      include 'DIMENSIONS'
1309       real(kind=8),parameter :: accur=1.0d-10
1310 !      include 'COMMON.GEO'
1311 !      include 'COMMON.VAR'
1312 !      include 'COMMON.LOCAL'
1313 !      include 'COMMON.CHAIN'
1314 !      include 'COMMON.DERIV'
1315 !      include 'COMMON.INTERACT'
1316 !      include 'COMMON.TORSION'
1317 !      include 'COMMON.SBRIDGE'
1318 !      include 'COMMON.NAMES'
1319 !      include 'COMMON.IOUNITS'
1320 !      include 'COMMON.CONTACTS'
1321       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1322       integer :: num_conti
1323 !el local variables
1324       integer :: i,itypi,iint,j,itypi1,itypj,k
1325       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
1326       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1327       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1328
1329 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1330       evdw=0.0D0
1331 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1332 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1333 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1334 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1335
1336       do i=iatsc_s,iatsc_e
1337         itypi=iabs(itype(i,1))
1338         if (itypi.eq.ntyp1) cycle
1339         itypi1=iabs(itype(i+1,1))
1340         xi=c(1,nres+i)
1341         yi=c(2,nres+i)
1342         zi=c(3,nres+i)
1343 ! Change 12/1/95
1344         num_conti=0
1345 !
1346 ! Calculate SC interaction energy.
1347 !
1348         do iint=1,nint_gr(i)
1349 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1350 !d   &                  'iend=',iend(i,iint)
1351           do j=istart(i,iint),iend(i,iint)
1352             itypj=iabs(itype(j,1))
1353             if (itypj.eq.ntyp1) cycle
1354             xj=c(1,nres+j)-xi
1355             yj=c(2,nres+j)-yi
1356             zj=c(3,nres+j)-zi
1357 ! Change 12/1/95 to calculate four-body interactions
1358             rij=xj*xj+yj*yj+zj*zj
1359             rrij=1.0D0/rij
1360 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1361             eps0ij=eps(itypi,itypj)
1362             fac=rrij**expon2
1363             e1=fac*fac*aa_aq(itypi,itypj)
1364             e2=fac*bb_aq(itypi,itypj)
1365             evdwij=e1+e2
1366 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1367 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1368 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1369 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1370 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1371 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1372             evdw=evdw+evdwij
1373 !
1374 ! Calculate the components of the gradient in DC and X
1375 !
1376             fac=-rrij*(e1+evdwij)
1377             gg(1)=xj*fac
1378             gg(2)=yj*fac
1379             gg(3)=zj*fac
1380             do k=1,3
1381               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1382               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1383               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1384               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1385             enddo
1386 !grad            do k=i,j-1
1387 !grad              do l=1,3
1388 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1389 !grad              enddo
1390 !grad            enddo
1391 !
1392 ! 12/1/95, revised on 5/20/97
1393 !
1394 ! Calculate the contact function. The ith column of the array JCONT will
1395 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1396 ! greater than I). The arrays FACONT and GACONT will contain the values of
1397 ! the contact function and its derivative.
1398 !
1399 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1400 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1401 ! Uncomment next line, if the correlation interactions are contact function only
1402             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1403               rij=dsqrt(rij)
1404               sigij=sigma(itypi,itypj)
1405               r0ij=rs0(itypi,itypj)
1406 !
1407 ! Check whether the SC's are not too far to make a contact.
1408 !
1409               rcut=1.5d0*r0ij
1410               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1411 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1412 !
1413               if (fcont.gt.0.0D0) then
1414 ! If the SC-SC distance if close to sigma, apply spline.
1415 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1416 !Adam &             fcont1,fprimcont1)
1417 !Adam           fcont1=1.0d0-fcont1
1418 !Adam           if (fcont1.gt.0.0d0) then
1419 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1420 !Adam             fcont=fcont*fcont1
1421 !Adam           endif
1422 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1423 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1424 !ga             do k=1,3
1425 !ga               gg(k)=gg(k)*eps0ij
1426 !ga             enddo
1427 !ga             eps0ij=-evdwij*eps0ij
1428 ! Uncomment for AL's type of SC correlation interactions.
1429 !adam           eps0ij=-evdwij
1430                 num_conti=num_conti+1
1431                 jcont(num_conti,i)=j
1432                 facont(num_conti,i)=fcont*eps0ij
1433                 fprimcont=eps0ij*fprimcont/rij
1434                 fcont=expon*fcont
1435 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1436 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1437 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1438 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1439                 gacont(1,num_conti,i)=-fprimcont*xj
1440                 gacont(2,num_conti,i)=-fprimcont*yj
1441                 gacont(3,num_conti,i)=-fprimcont*zj
1442 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1443 !d              write (iout,'(2i3,3f10.5)')
1444 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1445               endif
1446             endif
1447           enddo      ! j
1448         enddo        ! iint
1449 ! Change 12/1/95
1450         num_cont(i)=num_conti
1451       enddo          ! i
1452       do i=1,nct
1453         do j=1,3
1454           gvdwc(j,i)=expon*gvdwc(j,i)
1455           gvdwx(j,i)=expon*gvdwx(j,i)
1456         enddo
1457       enddo
1458 !******************************************************************************
1459 !
1460 !                              N O T E !!!
1461 !
1462 ! To save time, the factor of EXPON has been extracted from ALL components
1463 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1464 ! use!
1465 !
1466 !******************************************************************************
1467       return
1468       end subroutine elj
1469 !-----------------------------------------------------------------------------
1470       subroutine eljk(evdw)
1471 !
1472 ! This subroutine calculates the interaction energy of nonbonded side chains
1473 ! assuming the LJK potential of interaction.
1474 !
1475 !      implicit real*8 (a-h,o-z)
1476 !      include 'DIMENSIONS'
1477 !      include 'COMMON.GEO'
1478 !      include 'COMMON.VAR'
1479 !      include 'COMMON.LOCAL'
1480 !      include 'COMMON.CHAIN'
1481 !      include 'COMMON.DERIV'
1482 !      include 'COMMON.INTERACT'
1483 !      include 'COMMON.IOUNITS'
1484 !      include 'COMMON.NAMES'
1485       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1486       logical :: scheck
1487 !el local variables
1488       integer :: i,iint,j,itypi,itypi1,k,itypj
1489       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1490       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1491
1492 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1493       evdw=0.0D0
1494       do i=iatsc_s,iatsc_e
1495         itypi=iabs(itype(i,1))
1496         if (itypi.eq.ntyp1) cycle
1497         itypi1=iabs(itype(i+1,1))
1498         xi=c(1,nres+i)
1499         yi=c(2,nres+i)
1500         zi=c(3,nres+i)
1501 !
1502 ! Calculate SC interaction energy.
1503 !
1504         do iint=1,nint_gr(i)
1505           do j=istart(i,iint),iend(i,iint)
1506             itypj=iabs(itype(j,1))
1507             if (itypj.eq.ntyp1) cycle
1508             xj=c(1,nres+j)-xi
1509             yj=c(2,nres+j)-yi
1510             zj=c(3,nres+j)-zi
1511             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1512             fac_augm=rrij**expon
1513             e_augm=augm(itypi,itypj)*fac_augm
1514             r_inv_ij=dsqrt(rrij)
1515             rij=1.0D0/r_inv_ij
1516             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1517             fac=r_shift_inv**expon
1518             e1=fac*fac*aa_aq(itypi,itypj)
1519             e2=fac*bb_aq(itypi,itypj)
1520             evdwij=e_augm+e1+e2
1521 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1522 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1523 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1524 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1525 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1526 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1527 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1528             evdw=evdw+evdwij
1529 !
1530 ! Calculate the components of the gradient in DC and X
1531 !
1532             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1533             gg(1)=xj*fac
1534             gg(2)=yj*fac
1535             gg(3)=zj*fac
1536             do k=1,3
1537               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1538               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1539               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1540               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1541             enddo
1542 !grad            do k=i,j-1
1543 !grad              do l=1,3
1544 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1545 !grad              enddo
1546 !grad            enddo
1547           enddo      ! j
1548         enddo        ! iint
1549       enddo          ! i
1550       do i=1,nct
1551         do j=1,3
1552           gvdwc(j,i)=expon*gvdwc(j,i)
1553           gvdwx(j,i)=expon*gvdwx(j,i)
1554         enddo
1555       enddo
1556       return
1557       end subroutine eljk
1558 !-----------------------------------------------------------------------------
1559       subroutine ebp(evdw)
1560 !
1561 ! This subroutine calculates the interaction energy of nonbonded side chains
1562 ! assuming the Berne-Pechukas potential of interaction.
1563 !
1564       use comm_srutu
1565       use calc_data
1566 !      implicit real*8 (a-h,o-z)
1567 !      include 'DIMENSIONS'
1568 !      include 'COMMON.GEO'
1569 !      include 'COMMON.VAR'
1570 !      include 'COMMON.LOCAL'
1571 !      include 'COMMON.CHAIN'
1572 !      include 'COMMON.DERIV'
1573 !      include 'COMMON.NAMES'
1574 !      include 'COMMON.INTERACT'
1575 !      include 'COMMON.IOUNITS'
1576 !      include 'COMMON.CALC'
1577       use comm_srutu
1578 !el      integer :: icall
1579 !el      common /srutu/ icall
1580 !     double precision rrsave(maxdim)
1581       logical :: lprn
1582 !el local variables
1583       integer :: iint,itypi,itypi1,itypj
1584       real(kind=8) :: rrij,xi,yi,zi
1585       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1586
1587 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1588       evdw=0.0D0
1589 !     if (icall.eq.0) then
1590 !       lprn=.true.
1591 !     else
1592         lprn=.false.
1593 !     endif
1594 !el      ind=0
1595       do i=iatsc_s,iatsc_e
1596         itypi=iabs(itype(i,1))
1597         if (itypi.eq.ntyp1) cycle
1598         itypi1=iabs(itype(i+1,1))
1599         xi=c(1,nres+i)
1600         yi=c(2,nres+i)
1601         zi=c(3,nres+i)
1602         dxi=dc_norm(1,nres+i)
1603         dyi=dc_norm(2,nres+i)
1604         dzi=dc_norm(3,nres+i)
1605 !        dsci_inv=dsc_inv(itypi)
1606         dsci_inv=vbld_inv(i+nres)
1607 !
1608 ! Calculate SC interaction energy.
1609 !
1610         do iint=1,nint_gr(i)
1611           do j=istart(i,iint),iend(i,iint)
1612 !el            ind=ind+1
1613             itypj=iabs(itype(j,1))
1614             if (itypj.eq.ntyp1) cycle
1615 !            dscj_inv=dsc_inv(itypj)
1616             dscj_inv=vbld_inv(j+nres)
1617             chi1=chi(itypi,itypj)
1618             chi2=chi(itypj,itypi)
1619             chi12=chi1*chi2
1620             chip1=chip(itypi)
1621             chip2=chip(itypj)
1622             chip12=chip1*chip2
1623             alf1=alp(itypi)
1624             alf2=alp(itypj)
1625             alf12=0.5D0*(alf1+alf2)
1626 ! For diagnostics only!!!
1627 !           chi1=0.0D0
1628 !           chi2=0.0D0
1629 !           chi12=0.0D0
1630 !           chip1=0.0D0
1631 !           chip2=0.0D0
1632 !           chip12=0.0D0
1633 !           alf1=0.0D0
1634 !           alf2=0.0D0
1635 !           alf12=0.0D0
1636             xj=c(1,nres+j)-xi
1637             yj=c(2,nres+j)-yi
1638             zj=c(3,nres+j)-zi
1639             dxj=dc_norm(1,nres+j)
1640             dyj=dc_norm(2,nres+j)
1641             dzj=dc_norm(3,nres+j)
1642             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1643 !d          if (icall.eq.0) then
1644 !d            rrsave(ind)=rrij
1645 !d          else
1646 !d            rrij=rrsave(ind)
1647 !d          endif
1648             rij=dsqrt(rrij)
1649 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1650             call sc_angular
1651 ! Calculate whole angle-dependent part of epsilon and contributions
1652 ! to its derivatives
1653             fac=(rrij*sigsq)**expon2
1654             e1=fac*fac*aa_aq(itypi,itypj)
1655             e2=fac*bb_aq(itypi,itypj)
1656             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1657             eps2der=evdwij*eps3rt
1658             eps3der=evdwij*eps2rt
1659             evdwij=evdwij*eps2rt*eps3rt
1660             evdw=evdw+evdwij
1661             if (lprn) then
1662             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1663             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1664 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1665 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1666 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1667 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1668 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1669 !d     &        evdwij
1670             endif
1671 ! Calculate gradient components.
1672             e1=e1*eps1*eps2rt**2*eps3rt**2
1673             fac=-expon*(e1+evdwij)
1674             sigder=fac/sigsq
1675             fac=rrij*fac
1676 ! Calculate radial part of the gradient
1677             gg(1)=xj*fac
1678             gg(2)=yj*fac
1679             gg(3)=zj*fac
1680 ! Calculate the angular part of the gradient and sum add the contributions
1681 ! to the appropriate components of the Cartesian gradient.
1682             call sc_grad
1683           enddo      ! j
1684         enddo        ! iint
1685       enddo          ! i
1686 !     stop
1687       return
1688       end subroutine ebp
1689 !-----------------------------------------------------------------------------
1690       subroutine egb(evdw)
1691 !
1692 ! This subroutine calculates the interaction energy of nonbonded side chains
1693 ! assuming the Gay-Berne potential of interaction.
1694 !
1695       use calc_data
1696 !      implicit real*8 (a-h,o-z)
1697 !      include 'DIMENSIONS'
1698 !      include 'COMMON.GEO'
1699 !      include 'COMMON.VAR'
1700 !      include 'COMMON.LOCAL'
1701 !      include 'COMMON.CHAIN'
1702 !      include 'COMMON.DERIV'
1703 !      include 'COMMON.NAMES'
1704 !      include 'COMMON.INTERACT'
1705 !      include 'COMMON.IOUNITS'
1706 !      include 'COMMON.CALC'
1707 !      include 'COMMON.CONTROL'
1708 !      include 'COMMON.SBRIDGE'
1709       logical :: lprn
1710 !el local variables
1711       integer :: iint,itypi,itypi1,itypj,subchap
1712       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1713       real(kind=8) :: evdw,sig0ij
1714       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1715                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1716                     sslipi,sslipj,faclip
1717       integer :: ii
1718       real(kind=8) :: fracinbuf
1719
1720 !cccc      energy_dec=.false.
1721 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1722       evdw=0.0D0
1723       lprn=.false.
1724 !     if (icall.eq.0) lprn=.false.
1725 !el      ind=0
1726       dCAVdOM2=0.0d0
1727       dGCLdOM2=0.0d0
1728       dPOLdOM2=0.0d0
1729       dCAVdOM1=0.0d0
1730       dGCLdOM1=0.0d0
1731       dPOLdOM1=0.0d0
1732
1733
1734       do i=iatsc_s,iatsc_e
1735 !C        print *,"I am in EVDW",i
1736         itypi=iabs(itype(i,1))
1737 !        if (i.ne.47) cycle
1738         if (itypi.eq.ntyp1) cycle
1739         itypi1=iabs(itype(i+1,1))
1740         xi=c(1,nres+i)
1741         yi=c(2,nres+i)
1742         zi=c(3,nres+i)
1743           xi=dmod(xi,boxxsize)
1744           if (xi.lt.0) xi=xi+boxxsize
1745           yi=dmod(yi,boxysize)
1746           if (yi.lt.0) yi=yi+boxysize
1747           zi=dmod(zi,boxzsize)
1748           if (zi.lt.0) zi=zi+boxzsize
1749
1750        if ((zi.gt.bordlipbot)  &
1751         .and.(zi.lt.bordliptop)) then
1752 !C the energy transfer exist
1753         if (zi.lt.buflipbot) then
1754 !C what fraction I am in
1755          fracinbuf=1.0d0-  &
1756               ((zi-bordlipbot)/lipbufthick)
1757 !C lipbufthick is thickenes of lipid buffore
1758          sslipi=sscalelip(fracinbuf)
1759          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1760         elseif (zi.gt.bufliptop) then
1761          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1762          sslipi=sscalelip(fracinbuf)
1763          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1764         else
1765          sslipi=1.0d0
1766          ssgradlipi=0.0
1767         endif
1768        else
1769          sslipi=0.0d0
1770          ssgradlipi=0.0
1771        endif
1772 !       print *, sslipi,ssgradlipi
1773         dxi=dc_norm(1,nres+i)
1774         dyi=dc_norm(2,nres+i)
1775         dzi=dc_norm(3,nres+i)
1776 !        dsci_inv=dsc_inv(itypi)
1777         dsci_inv=vbld_inv(i+nres)
1778 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1779 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1780 !
1781 ! Calculate SC interaction energy.
1782 !
1783         do iint=1,nint_gr(i)
1784           do j=istart(i,iint),iend(i,iint)
1785             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1786               call dyn_ssbond_ene(i,j,evdwij)
1787               evdw=evdw+evdwij
1788               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1789                               'evdw',i,j,evdwij,' ss'
1790 !              if (energy_dec) write (iout,*) &
1791 !                              'evdw',i,j,evdwij,' ss'
1792              do k=j+1,iend(i,iint)
1793 !C search over all next residues
1794               if (dyn_ss_mask(k)) then
1795 !C check if they are cysteins
1796 !C              write(iout,*) 'k=',k
1797
1798 !c              write(iout,*) "PRZED TRI", evdwij
1799 !               evdwij_przed_tri=evdwij
1800               call triple_ssbond_ene(i,j,k,evdwij)
1801 !c               if(evdwij_przed_tri.ne.evdwij) then
1802 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1803 !c               endif
1804
1805 !c              write(iout,*) "PO TRI", evdwij
1806 !C call the energy function that removes the artifical triple disulfide
1807 !C bond the soubroutine is located in ssMD.F
1808               evdw=evdw+evdwij
1809               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1810                             'evdw',i,j,evdwij,'tss'
1811               endif!dyn_ss_mask(k)
1812              enddo! k
1813             ELSE
1814 !el            ind=ind+1
1815             itypj=iabs(itype(j,1))
1816             if (itypj.eq.ntyp1) cycle
1817 !             if (j.ne.78) cycle
1818 !            dscj_inv=dsc_inv(itypj)
1819             dscj_inv=vbld_inv(j+nres)
1820 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1821 !              1.0d0/vbld(j+nres) !d
1822 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1823             sig0ij=sigma(itypi,itypj)
1824             chi1=chi(itypi,itypj)
1825             chi2=chi(itypj,itypi)
1826             chi12=chi1*chi2
1827             chip1=chip(itypi)
1828             chip2=chip(itypj)
1829             chip12=chip1*chip2
1830             alf1=alp(itypi)
1831             alf2=alp(itypj)
1832             alf12=0.5D0*(alf1+alf2)
1833 ! For diagnostics only!!!
1834 !           chi1=0.0D0
1835 !           chi2=0.0D0
1836 !           chi12=0.0D0
1837 !           chip1=0.0D0
1838 !           chip2=0.0D0
1839 !           chip12=0.0D0
1840 !           alf1=0.0D0
1841 !           alf2=0.0D0
1842 !           alf12=0.0D0
1843            xj=c(1,nres+j)
1844            yj=c(2,nres+j)
1845            zj=c(3,nres+j)
1846           xj=dmod(xj,boxxsize)
1847           if (xj.lt.0) xj=xj+boxxsize
1848           yj=dmod(yj,boxysize)
1849           if (yj.lt.0) yj=yj+boxysize
1850           zj=dmod(zj,boxzsize)
1851           if (zj.lt.0) zj=zj+boxzsize
1852 !          print *,"tu",xi,yi,zi,xj,yj,zj
1853 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1854 ! this fragment set correct epsilon for lipid phase
1855        if ((zj.gt.bordlipbot)  &
1856        .and.(zj.lt.bordliptop)) then
1857 !C the energy transfer exist
1858         if (zj.lt.buflipbot) then
1859 !C what fraction I am in
1860          fracinbuf=1.0d0-     &
1861              ((zj-bordlipbot)/lipbufthick)
1862 !C lipbufthick is thickenes of lipid buffore
1863          sslipj=sscalelip(fracinbuf)
1864          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1865         elseif (zj.gt.bufliptop) then
1866          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1867          sslipj=sscalelip(fracinbuf)
1868          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1869         else
1870          sslipj=1.0d0
1871          ssgradlipj=0.0
1872         endif
1873        else
1874          sslipj=0.0d0
1875          ssgradlipj=0.0
1876        endif
1877       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1878        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1879       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1880        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1881 !------------------------------------------------
1882       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1883       xj_safe=xj
1884       yj_safe=yj
1885       zj_safe=zj
1886       subchap=0
1887       do xshift=-1,1
1888       do yshift=-1,1
1889       do zshift=-1,1
1890           xj=xj_safe+xshift*boxxsize
1891           yj=yj_safe+yshift*boxysize
1892           zj=zj_safe+zshift*boxzsize
1893           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1894           if(dist_temp.lt.dist_init) then
1895             dist_init=dist_temp
1896             xj_temp=xj
1897             yj_temp=yj
1898             zj_temp=zj
1899             subchap=1
1900           endif
1901        enddo
1902        enddo
1903        enddo
1904        if (subchap.eq.1) then
1905           xj=xj_temp-xi
1906           yj=yj_temp-yi
1907           zj=zj_temp-zi
1908        else
1909           xj=xj_safe-xi
1910           yj=yj_safe-yi
1911           zj=zj_safe-zi
1912        endif
1913             dxj=dc_norm(1,nres+j)
1914             dyj=dc_norm(2,nres+j)
1915             dzj=dc_norm(3,nres+j)
1916 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1917 !            write (iout,*) "j",j," dc_norm",& !d
1918 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1919 !          write(iout,*)"rrij ",rrij
1920 !          write(iout,*)"xj yj zj ", xj, yj, zj
1921 !          write(iout,*)"xi yi zi ", xi, yi, zi
1922 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1923             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1924             rij=dsqrt(rrij)
1925             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1926             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1927 !            print *,sss_ele_cut,sss_ele_grad,&
1928 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1929             if (sss_ele_cut.le.0.0) cycle
1930 ! Calculate angle-dependent terms of energy and contributions to their
1931 ! derivatives.
1932             call sc_angular
1933             sigsq=1.0D0/sigsq
1934             sig=sig0ij*dsqrt(sigsq)
1935             rij_shift=1.0D0/rij-sig+sig0ij
1936 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1937 !            "sig0ij",sig0ij
1938 ! for diagnostics; uncomment
1939 !            rij_shift=1.2*sig0ij
1940 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1941             if (rij_shift.le.0.0D0) then
1942               evdw=1.0D20
1943 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1944 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1945 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1946               return
1947             endif
1948             sigder=-sig*sigsq
1949 !---------------------------------------------------------------
1950             rij_shift=1.0D0/rij_shift
1951             fac=rij_shift**expon
1952             faclip=fac
1953             e1=fac*fac*aa!(itypi,itypj)
1954             e2=fac*bb!(itypi,itypj)
1955             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1956             eps2der=evdwij*eps3rt
1957             eps3der=evdwij*eps2rt
1958 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1959 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1960 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1961             evdwij=evdwij*eps2rt*eps3rt
1962             evdw=evdw+evdwij*sss_ele_cut
1963             if (lprn) then
1964             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1965             epsi=bb**2/aa!(itypi,itypj)
1966             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1967               restyp(itypi,1),i,restyp(itypj,1),j, &
1968               epsi,sigm,chi1,chi2,chip1,chip2, &
1969               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1970               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1971               evdwij
1972             endif
1973
1974             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
1975                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
1976 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
1977 !            if (energy_dec) write (iout,*) &
1978 !                             'evdw',i,j,evdwij
1979 !                       print *,"ZALAMKA", evdw
1980
1981 ! Calculate gradient components.
1982             e1=e1*eps1*eps2rt**2*eps3rt**2
1983             fac=-expon*(e1+evdwij)*rij_shift
1984             sigder=fac*sigder
1985             fac=rij*fac
1986 !            print *,'before fac',fac,rij,evdwij
1987             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1988             /sigma(itypi,itypj)*rij
1989 !            print *,'grad part scale',fac,   &
1990 !             evdwij*sss_ele_grad/sss_ele_cut &
1991 !            /sigma(itypi,itypj)*rij
1992 !            fac=0.0d0
1993 ! Calculate the radial part of the gradient
1994             gg(1)=xj*fac
1995             gg(2)=yj*fac
1996             gg(3)=zj*fac
1997 !C Calculate the radial part of the gradient
1998             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
1999        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
2000         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
2001        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2002             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2003             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2004
2005 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
2006 ! Calculate angular part of the gradient.
2007             call sc_grad
2008             ENDIF    ! dyn_ss
2009           enddo      ! j
2010         enddo        ! iint
2011       enddo          ! i
2012 !       print *,"ZALAMKA", evdw
2013 !      write (iout,*) "Number of loop steps in EGB:",ind
2014 !ccc      energy_dec=.false.
2015       return
2016       end subroutine egb
2017 !-----------------------------------------------------------------------------
2018       subroutine egbv(evdw)
2019 !
2020 ! This subroutine calculates the interaction energy of nonbonded side chains
2021 ! assuming the Gay-Berne-Vorobjev potential of interaction.
2022 !
2023       use comm_srutu
2024       use calc_data
2025 !      implicit real*8 (a-h,o-z)
2026 !      include 'DIMENSIONS'
2027 !      include 'COMMON.GEO'
2028 !      include 'COMMON.VAR'
2029 !      include 'COMMON.LOCAL'
2030 !      include 'COMMON.CHAIN'
2031 !      include 'COMMON.DERIV'
2032 !      include 'COMMON.NAMES'
2033 !      include 'COMMON.INTERACT'
2034 !      include 'COMMON.IOUNITS'
2035 !      include 'COMMON.CALC'
2036       use comm_srutu
2037 !el      integer :: icall
2038 !el      common /srutu/ icall
2039       logical :: lprn
2040 !el local variables
2041       integer :: iint,itypi,itypi1,itypj
2042       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
2043       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
2044
2045 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2046       evdw=0.0D0
2047       lprn=.false.
2048 !     if (icall.eq.0) lprn=.true.
2049 !el      ind=0
2050       do i=iatsc_s,iatsc_e
2051         itypi=iabs(itype(i,1))
2052         if (itypi.eq.ntyp1) cycle
2053         itypi1=iabs(itype(i+1,1))
2054         xi=c(1,nres+i)
2055         yi=c(2,nres+i)
2056         zi=c(3,nres+i)
2057         dxi=dc_norm(1,nres+i)
2058         dyi=dc_norm(2,nres+i)
2059         dzi=dc_norm(3,nres+i)
2060 !        dsci_inv=dsc_inv(itypi)
2061         dsci_inv=vbld_inv(i+nres)
2062 !
2063 ! Calculate SC interaction energy.
2064 !
2065         do iint=1,nint_gr(i)
2066           do j=istart(i,iint),iend(i,iint)
2067 !el            ind=ind+1
2068             itypj=iabs(itype(j,1))
2069             if (itypj.eq.ntyp1) cycle
2070 !            dscj_inv=dsc_inv(itypj)
2071             dscj_inv=vbld_inv(j+nres)
2072             sig0ij=sigma(itypi,itypj)
2073             r0ij=r0(itypi,itypj)
2074             chi1=chi(itypi,itypj)
2075             chi2=chi(itypj,itypi)
2076             chi12=chi1*chi2
2077             chip1=chip(itypi)
2078             chip2=chip(itypj)
2079             chip12=chip1*chip2
2080             alf1=alp(itypi)
2081             alf2=alp(itypj)
2082             alf12=0.5D0*(alf1+alf2)
2083 ! For diagnostics only!!!
2084 !           chi1=0.0D0
2085 !           chi2=0.0D0
2086 !           chi12=0.0D0
2087 !           chip1=0.0D0
2088 !           chip2=0.0D0
2089 !           chip12=0.0D0
2090 !           alf1=0.0D0
2091 !           alf2=0.0D0
2092 !           alf12=0.0D0
2093             xj=c(1,nres+j)-xi
2094             yj=c(2,nres+j)-yi
2095             zj=c(3,nres+j)-zi
2096             dxj=dc_norm(1,nres+j)
2097             dyj=dc_norm(2,nres+j)
2098             dzj=dc_norm(3,nres+j)
2099             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2100             rij=dsqrt(rrij)
2101 ! Calculate angle-dependent terms of energy and contributions to their
2102 ! derivatives.
2103             call sc_angular
2104             sigsq=1.0D0/sigsq
2105             sig=sig0ij*dsqrt(sigsq)
2106             rij_shift=1.0D0/rij-sig+r0ij
2107 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2108             if (rij_shift.le.0.0D0) then
2109               evdw=1.0D20
2110               return
2111             endif
2112             sigder=-sig*sigsq
2113 !---------------------------------------------------------------
2114             rij_shift=1.0D0/rij_shift
2115             fac=rij_shift**expon
2116             e1=fac*fac*aa_aq(itypi,itypj)
2117             e2=fac*bb_aq(itypi,itypj)
2118             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2119             eps2der=evdwij*eps3rt
2120             eps3der=evdwij*eps2rt
2121             fac_augm=rrij**expon
2122             e_augm=augm(itypi,itypj)*fac_augm
2123             evdwij=evdwij*eps2rt*eps3rt
2124             evdw=evdw+evdwij+e_augm
2125             if (lprn) then
2126             sigm=dabs(aa_aq(itypi,itypj)/&
2127             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2128             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2129             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2130               restyp(itypi,1),i,restyp(itypj,1),j,&
2131               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2132               chi1,chi2,chip1,chip2,&
2133               eps1,eps2rt**2,eps3rt**2,&
2134               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2135               evdwij+e_augm
2136             endif
2137 ! Calculate gradient components.
2138             e1=e1*eps1*eps2rt**2*eps3rt**2
2139             fac=-expon*(e1+evdwij)*rij_shift
2140             sigder=fac*sigder
2141             fac=rij*fac-2*expon*rrij*e_augm
2142 ! Calculate the radial part of the gradient
2143             gg(1)=xj*fac
2144             gg(2)=yj*fac
2145             gg(3)=zj*fac
2146 ! Calculate angular part of the gradient.
2147             call sc_grad
2148           enddo      ! j
2149         enddo        ! iint
2150       enddo          ! i
2151       end subroutine egbv
2152 !-----------------------------------------------------------------------------
2153 !el      subroutine sc_angular in module geometry
2154 !-----------------------------------------------------------------------------
2155       subroutine e_softsphere(evdw)
2156 !
2157 ! This subroutine calculates the interaction energy of nonbonded side chains
2158 ! assuming the LJ potential of interaction.
2159 !
2160 !      implicit real*8 (a-h,o-z)
2161 !      include 'DIMENSIONS'
2162       real(kind=8),parameter :: accur=1.0d-10
2163 !      include 'COMMON.GEO'
2164 !      include 'COMMON.VAR'
2165 !      include 'COMMON.LOCAL'
2166 !      include 'COMMON.CHAIN'
2167 !      include 'COMMON.DERIV'
2168 !      include 'COMMON.INTERACT'
2169 !      include 'COMMON.TORSION'
2170 !      include 'COMMON.SBRIDGE'
2171 !      include 'COMMON.NAMES'
2172 !      include 'COMMON.IOUNITS'
2173 !      include 'COMMON.CONTACTS'
2174       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2175 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2176 !el local variables
2177       integer :: i,iint,j,itypi,itypi1,itypj,k
2178       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2179       real(kind=8) :: fac
2180
2181       evdw=0.0D0
2182       do i=iatsc_s,iatsc_e
2183         itypi=iabs(itype(i,1))
2184         if (itypi.eq.ntyp1) cycle
2185         itypi1=iabs(itype(i+1,1))
2186         xi=c(1,nres+i)
2187         yi=c(2,nres+i)
2188         zi=c(3,nres+i)
2189 !
2190 ! Calculate SC interaction energy.
2191 !
2192         do iint=1,nint_gr(i)
2193 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2194 !d   &                  'iend=',iend(i,iint)
2195           do j=istart(i,iint),iend(i,iint)
2196             itypj=iabs(itype(j,1))
2197             if (itypj.eq.ntyp1) cycle
2198             xj=c(1,nres+j)-xi
2199             yj=c(2,nres+j)-yi
2200             zj=c(3,nres+j)-zi
2201             rij=xj*xj+yj*yj+zj*zj
2202 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2203             r0ij=r0(itypi,itypj)
2204             r0ijsq=r0ij*r0ij
2205 !            print *,i,j,r0ij,dsqrt(rij)
2206             if (rij.lt.r0ijsq) then
2207               evdwij=0.25d0*(rij-r0ijsq)**2
2208               fac=rij-r0ijsq
2209             else
2210               evdwij=0.0d0
2211               fac=0.0d0
2212             endif
2213             evdw=evdw+evdwij
2214 !
2215 ! Calculate the components of the gradient in DC and X
2216 !
2217             gg(1)=xj*fac
2218             gg(2)=yj*fac
2219             gg(3)=zj*fac
2220             do k=1,3
2221               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2222               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2223               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2224               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2225             enddo
2226 !grad            do k=i,j-1
2227 !grad              do l=1,3
2228 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2229 !grad              enddo
2230 !grad            enddo
2231           enddo ! j
2232         enddo ! iint
2233       enddo ! i
2234       return
2235       end subroutine e_softsphere
2236 !-----------------------------------------------------------------------------
2237       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2238 !
2239 ! Soft-sphere potential of p-p interaction
2240 !
2241 !      implicit real*8 (a-h,o-z)
2242 !      include 'DIMENSIONS'
2243 !      include 'COMMON.CONTROL'
2244 !      include 'COMMON.IOUNITS'
2245 !      include 'COMMON.GEO'
2246 !      include 'COMMON.VAR'
2247 !      include 'COMMON.LOCAL'
2248 !      include 'COMMON.CHAIN'
2249 !      include 'COMMON.DERIV'
2250 !      include 'COMMON.INTERACT'
2251 !      include 'COMMON.CONTACTS'
2252 !      include 'COMMON.TORSION'
2253 !      include 'COMMON.VECTORS'
2254 !      include 'COMMON.FFIELD'
2255       real(kind=8),dimension(3) :: ggg
2256 !d      write(iout,*) 'In EELEC_soft_sphere'
2257 !el local variables
2258       integer :: i,j,k,num_conti,iteli,itelj
2259       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2260       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2261       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2262
2263       ees=0.0D0
2264       evdw1=0.0D0
2265       eel_loc=0.0d0
2266       eello_turn3=0.0d0
2267       eello_turn4=0.0d0
2268 !el      ind=0
2269       do i=iatel_s,iatel_e
2270         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2271         dxi=dc(1,i)
2272         dyi=dc(2,i)
2273         dzi=dc(3,i)
2274         xmedi=c(1,i)+0.5d0*dxi
2275         ymedi=c(2,i)+0.5d0*dyi
2276         zmedi=c(3,i)+0.5d0*dzi
2277         num_conti=0
2278 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2279         do j=ielstart(i),ielend(i)
2280           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2281 !el          ind=ind+1
2282           iteli=itel(i)
2283           itelj=itel(j)
2284           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2285           r0ij=rpp(iteli,itelj)
2286           r0ijsq=r0ij*r0ij
2287           dxj=dc(1,j)
2288           dyj=dc(2,j)
2289           dzj=dc(3,j)
2290           xj=c(1,j)+0.5D0*dxj-xmedi
2291           yj=c(2,j)+0.5D0*dyj-ymedi
2292           zj=c(3,j)+0.5D0*dzj-zmedi
2293           rij=xj*xj+yj*yj+zj*zj
2294           if (rij.lt.r0ijsq) then
2295             evdw1ij=0.25d0*(rij-r0ijsq)**2
2296             fac=rij-r0ijsq
2297           else
2298             evdw1ij=0.0d0
2299             fac=0.0d0
2300           endif
2301           evdw1=evdw1+evdw1ij
2302 !
2303 ! Calculate contributions to the Cartesian gradient.
2304 !
2305           ggg(1)=fac*xj
2306           ggg(2)=fac*yj
2307           ggg(3)=fac*zj
2308           do k=1,3
2309             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2310             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2311           enddo
2312 !
2313 ! Loop over residues i+1 thru j-1.
2314 !
2315 !grad          do k=i+1,j-1
2316 !grad            do l=1,3
2317 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2318 !grad            enddo
2319 !grad          enddo
2320         enddo ! j
2321       enddo   ! i
2322 !grad      do i=nnt,nct-1
2323 !grad        do k=1,3
2324 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2325 !grad        enddo
2326 !grad        do j=i+1,nct-1
2327 !grad          do k=1,3
2328 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2329 !grad          enddo
2330 !grad        enddo
2331 !grad      enddo
2332       return
2333       end subroutine eelec_soft_sphere
2334 !-----------------------------------------------------------------------------
2335       subroutine vec_and_deriv
2336 !      implicit real*8 (a-h,o-z)
2337 !      include 'DIMENSIONS'
2338 #ifdef MPI
2339       include 'mpif.h'
2340 #endif
2341 !      include 'COMMON.IOUNITS'
2342 !      include 'COMMON.GEO'
2343 !      include 'COMMON.VAR'
2344 !      include 'COMMON.LOCAL'
2345 !      include 'COMMON.CHAIN'
2346 !      include 'COMMON.VECTORS'
2347 !      include 'COMMON.SETUP'
2348 !      include 'COMMON.TIME1'
2349       real(kind=8),dimension(3,3,2) :: uyder,uzder
2350       real(kind=8),dimension(2) :: vbld_inv_temp
2351 ! Compute the local reference systems. For reference system (i), the
2352 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2353 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2354 !el local variables
2355       integer :: i,j,k,l
2356       real(kind=8) :: facy,fac,costh
2357
2358 #ifdef PARVEC
2359       do i=ivec_start,ivec_end
2360 #else
2361       do i=1,nres-1
2362 #endif
2363           if (i.eq.nres-1) then
2364 ! Case of the last full residue
2365 ! Compute the Z-axis
2366             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2367             costh=dcos(pi-theta(nres))
2368             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2369             do k=1,3
2370               uz(k,i)=fac*uz(k,i)
2371             enddo
2372 ! Compute the derivatives of uz
2373             uzder(1,1,1)= 0.0d0
2374             uzder(2,1,1)=-dc_norm(3,i-1)
2375             uzder(3,1,1)= dc_norm(2,i-1)
2376             uzder(1,2,1)= dc_norm(3,i-1)
2377             uzder(2,2,1)= 0.0d0
2378             uzder(3,2,1)=-dc_norm(1,i-1)
2379             uzder(1,3,1)=-dc_norm(2,i-1)
2380             uzder(2,3,1)= dc_norm(1,i-1)
2381             uzder(3,3,1)= 0.0d0
2382             uzder(1,1,2)= 0.0d0
2383             uzder(2,1,2)= dc_norm(3,i)
2384             uzder(3,1,2)=-dc_norm(2,i)
2385             uzder(1,2,2)=-dc_norm(3,i)
2386             uzder(2,2,2)= 0.0d0
2387             uzder(3,2,2)= dc_norm(1,i)
2388             uzder(1,3,2)= dc_norm(2,i)
2389             uzder(2,3,2)=-dc_norm(1,i)
2390             uzder(3,3,2)= 0.0d0
2391 ! Compute the Y-axis
2392             facy=fac
2393             do k=1,3
2394               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2395             enddo
2396 ! Compute the derivatives of uy
2397             do j=1,3
2398               do k=1,3
2399                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2400                               -dc_norm(k,i)*dc_norm(j,i-1)
2401                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2402               enddo
2403               uyder(j,j,1)=uyder(j,j,1)-costh
2404               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2405             enddo
2406             do j=1,2
2407               do k=1,3
2408                 do l=1,3
2409                   uygrad(l,k,j,i)=uyder(l,k,j)
2410                   uzgrad(l,k,j,i)=uzder(l,k,j)
2411                 enddo
2412               enddo
2413             enddo
2414             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2415             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2416             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2417             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2418           else
2419 ! Other residues
2420 ! Compute the Z-axis
2421             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2422             costh=dcos(pi-theta(i+2))
2423             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2424             do k=1,3
2425               uz(k,i)=fac*uz(k,i)
2426             enddo
2427 ! Compute the derivatives of uz
2428             uzder(1,1,1)= 0.0d0
2429             uzder(2,1,1)=-dc_norm(3,i+1)
2430             uzder(3,1,1)= dc_norm(2,i+1)
2431             uzder(1,2,1)= dc_norm(3,i+1)
2432             uzder(2,2,1)= 0.0d0
2433             uzder(3,2,1)=-dc_norm(1,i+1)
2434             uzder(1,3,1)=-dc_norm(2,i+1)
2435             uzder(2,3,1)= dc_norm(1,i+1)
2436             uzder(3,3,1)= 0.0d0
2437             uzder(1,1,2)= 0.0d0
2438             uzder(2,1,2)= dc_norm(3,i)
2439             uzder(3,1,2)=-dc_norm(2,i)
2440             uzder(1,2,2)=-dc_norm(3,i)
2441             uzder(2,2,2)= 0.0d0
2442             uzder(3,2,2)= dc_norm(1,i)
2443             uzder(1,3,2)= dc_norm(2,i)
2444             uzder(2,3,2)=-dc_norm(1,i)
2445             uzder(3,3,2)= 0.0d0
2446 ! Compute the Y-axis
2447             facy=fac
2448             do k=1,3
2449               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2450             enddo
2451 ! Compute the derivatives of uy
2452             do j=1,3
2453               do k=1,3
2454                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2455                               -dc_norm(k,i)*dc_norm(j,i+1)
2456                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2457               enddo
2458               uyder(j,j,1)=uyder(j,j,1)-costh
2459               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2460             enddo
2461             do j=1,2
2462               do k=1,3
2463                 do l=1,3
2464                   uygrad(l,k,j,i)=uyder(l,k,j)
2465                   uzgrad(l,k,j,i)=uzder(l,k,j)
2466                 enddo
2467               enddo
2468             enddo
2469             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2470             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2471             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2472             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2473           endif
2474       enddo
2475       do i=1,nres-1
2476         vbld_inv_temp(1)=vbld_inv(i+1)
2477         if (i.lt.nres-1) then
2478           vbld_inv_temp(2)=vbld_inv(i+2)
2479           else
2480           vbld_inv_temp(2)=vbld_inv(i)
2481           endif
2482         do j=1,2
2483           do k=1,3
2484             do l=1,3
2485               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2486               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2487             enddo
2488           enddo
2489         enddo
2490       enddo
2491 #if defined(PARVEC) && defined(MPI)
2492       if (nfgtasks1.gt.1) then
2493         time00=MPI_Wtime()
2494 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2495 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2496 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2497         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2498          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2499          FG_COMM1,IERR)
2500         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2501          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2502          FG_COMM1,IERR)
2503         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2504          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2505          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2506         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2507          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2508          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2509         time_gather=time_gather+MPI_Wtime()-time00
2510       endif
2511 !      if (fg_rank.eq.0) then
2512 !        write (iout,*) "Arrays UY and UZ"
2513 !        do i=1,nres-1
2514 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2515 !     &     (uz(k,i),k=1,3)
2516 !        enddo
2517 !      endif
2518 #endif
2519       return
2520       end subroutine vec_and_deriv
2521 !-----------------------------------------------------------------------------
2522       subroutine check_vecgrad
2523 !      implicit real*8 (a-h,o-z)
2524 !      include 'DIMENSIONS'
2525 !      include 'COMMON.IOUNITS'
2526 !      include 'COMMON.GEO'
2527 !      include 'COMMON.VAR'
2528 !      include 'COMMON.LOCAL'
2529 !      include 'COMMON.CHAIN'
2530 !      include 'COMMON.VECTORS'
2531       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2532       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2533       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2534       real(kind=8),dimension(3) :: erij
2535       real(kind=8) :: delta=1.0d-7
2536 !el local variables
2537       integer :: i,j,k,l
2538
2539       call vec_and_deriv
2540 !d      do i=1,nres
2541 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2542 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2543 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2544 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2545 !d     &     (dc_norm(if90,i),if90=1,3)
2546 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2547 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2548 !d          write(iout,'(a)')
2549 !d      enddo
2550       do i=1,nres
2551         do j=1,2
2552           do k=1,3
2553             do l=1,3
2554               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2555               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2556             enddo
2557           enddo
2558         enddo
2559       enddo
2560       call vec_and_deriv
2561       do i=1,nres
2562         do j=1,3
2563           uyt(j,i)=uy(j,i)
2564           uzt(j,i)=uz(j,i)
2565         enddo
2566       enddo
2567       do i=1,nres
2568 !d        write (iout,*) 'i=',i
2569         do k=1,3
2570           erij(k)=dc_norm(k,i)
2571         enddo
2572         do j=1,3
2573           do k=1,3
2574             dc_norm(k,i)=erij(k)
2575           enddo
2576           dc_norm(j,i)=dc_norm(j,i)+delta
2577 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2578 !          do k=1,3
2579 !            dc_norm(k,i)=dc_norm(k,i)/fac
2580 !          enddo
2581 !          write (iout,*) (dc_norm(k,i),k=1,3)
2582 !          write (iout,*) (erij(k),k=1,3)
2583           call vec_and_deriv
2584           do k=1,3
2585             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2586             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2587             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2588             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2589           enddo
2590 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2591 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2592 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2593         enddo
2594         do k=1,3
2595           dc_norm(k,i)=erij(k)
2596         enddo
2597 !d        do k=1,3
2598 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2599 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2600 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2601 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2602 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2603 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2604 !d          write (iout,'(a)')
2605 !d        enddo
2606       enddo
2607       return
2608       end subroutine check_vecgrad
2609 !-----------------------------------------------------------------------------
2610       subroutine set_matrices
2611 !      implicit real*8 (a-h,o-z)
2612 !      include 'DIMENSIONS'
2613 #ifdef MPI
2614       include "mpif.h"
2615 !      include "COMMON.SETUP"
2616       integer :: IERR
2617       integer :: status(MPI_STATUS_SIZE)
2618 #endif
2619 !      include 'COMMON.IOUNITS'
2620 !      include 'COMMON.GEO'
2621 !      include 'COMMON.VAR'
2622 !      include 'COMMON.LOCAL'
2623 !      include 'COMMON.CHAIN'
2624 !      include 'COMMON.DERIV'
2625 !      include 'COMMON.INTERACT'
2626 !      include 'COMMON.CONTACTS'
2627 !      include 'COMMON.TORSION'
2628 !      include 'COMMON.VECTORS'
2629 !      include 'COMMON.FFIELD'
2630       real(kind=8) :: auxvec(2),auxmat(2,2)
2631       integer :: i,iti1,iti,k,l
2632       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2633 !       print *,"in set matrices"
2634 !
2635 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2636 ! to calculate the el-loc multibody terms of various order.
2637 !
2638 !AL el      mu=0.0d0
2639 #ifdef PARMAT
2640       do i=ivec_start+2,ivec_end+2
2641 #else
2642       do i=3,nres+1
2643 #endif
2644 !      print *,i,"i"
2645         if (i .lt. nres+1) then
2646           sin1=dsin(phi(i))
2647           cos1=dcos(phi(i))
2648           sintab(i-2)=sin1
2649           costab(i-2)=cos1
2650           obrot(1,i-2)=cos1
2651           obrot(2,i-2)=sin1
2652           sin2=dsin(2*phi(i))
2653           cos2=dcos(2*phi(i))
2654           sintab2(i-2)=sin2
2655           costab2(i-2)=cos2
2656           obrot2(1,i-2)=cos2
2657           obrot2(2,i-2)=sin2
2658           Ug(1,1,i-2)=-cos1
2659           Ug(1,2,i-2)=-sin1
2660           Ug(2,1,i-2)=-sin1
2661           Ug(2,2,i-2)= cos1
2662           Ug2(1,1,i-2)=-cos2
2663           Ug2(1,2,i-2)=-sin2
2664           Ug2(2,1,i-2)=-sin2
2665           Ug2(2,2,i-2)= cos2
2666         else
2667           costab(i-2)=1.0d0
2668           sintab(i-2)=0.0d0
2669           obrot(1,i-2)=1.0d0
2670           obrot(2,i-2)=0.0d0
2671           obrot2(1,i-2)=0.0d0
2672           obrot2(2,i-2)=0.0d0
2673           Ug(1,1,i-2)=1.0d0
2674           Ug(1,2,i-2)=0.0d0
2675           Ug(2,1,i-2)=0.0d0
2676           Ug(2,2,i-2)=1.0d0
2677           Ug2(1,1,i-2)=0.0d0
2678           Ug2(1,2,i-2)=0.0d0
2679           Ug2(2,1,i-2)=0.0d0
2680           Ug2(2,2,i-2)=0.0d0
2681         endif
2682         if (i .gt. 3 .and. i .lt. nres+1) then
2683           obrot_der(1,i-2)=-sin1
2684           obrot_der(2,i-2)= cos1
2685           Ugder(1,1,i-2)= sin1
2686           Ugder(1,2,i-2)=-cos1
2687           Ugder(2,1,i-2)=-cos1
2688           Ugder(2,2,i-2)=-sin1
2689           dwacos2=cos2+cos2
2690           dwasin2=sin2+sin2
2691           obrot2_der(1,i-2)=-dwasin2
2692           obrot2_der(2,i-2)= dwacos2
2693           Ug2der(1,1,i-2)= dwasin2
2694           Ug2der(1,2,i-2)=-dwacos2
2695           Ug2der(2,1,i-2)=-dwacos2
2696           Ug2der(2,2,i-2)=-dwasin2
2697         else
2698           obrot_der(1,i-2)=0.0d0
2699           obrot_der(2,i-2)=0.0d0
2700           Ugder(1,1,i-2)=0.0d0
2701           Ugder(1,2,i-2)=0.0d0
2702           Ugder(2,1,i-2)=0.0d0
2703           Ugder(2,2,i-2)=0.0d0
2704           obrot2_der(1,i-2)=0.0d0
2705           obrot2_der(2,i-2)=0.0d0
2706           Ug2der(1,1,i-2)=0.0d0
2707           Ug2der(1,2,i-2)=0.0d0
2708           Ug2der(2,1,i-2)=0.0d0
2709           Ug2der(2,2,i-2)=0.0d0
2710         endif
2711 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2712         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2713            if (itype(i-2,1).eq.0) then
2714           iti=ntortyp+1
2715            else
2716           iti = itortyp(itype(i-2,1))
2717            endif
2718         else
2719           iti=ntortyp+1
2720         endif
2721 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2722         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2723            if (itype(i-1,1).eq.0) then
2724           iti1=ntortyp+1
2725            else
2726           iti1 = itortyp(itype(i-1,1))
2727            endif
2728         else
2729           iti1=ntortyp+1
2730         endif
2731 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2732 !d        write (iout,*) '*******i',i,' iti1',iti
2733 !d        write (iout,*) 'b1',b1(:,iti)
2734 !d        write (iout,*) 'b2',b2(:,iti)
2735 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2736 !        if (i .gt. iatel_s+2) then
2737         if (i .gt. nnt+2) then
2738           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2739           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2740           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2741           then
2742           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2743           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2744           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2745           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2746           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2747           endif
2748         else
2749           do k=1,2
2750             Ub2(k,i-2)=0.0d0
2751             Ctobr(k,i-2)=0.0d0
2752             Dtobr2(k,i-2)=0.0d0
2753             do l=1,2
2754               EUg(l,k,i-2)=0.0d0
2755               CUg(l,k,i-2)=0.0d0
2756               DUg(l,k,i-2)=0.0d0
2757               DtUg2(l,k,i-2)=0.0d0
2758             enddo
2759           enddo
2760         endif
2761         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2762         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2763         do k=1,2
2764           muder(k,i-2)=Ub2der(k,i-2)
2765         enddo
2766 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2767         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2768           if (itype(i-1,1).eq.0) then
2769            iti1=ntortyp+1
2770           elseif (itype(i-1,1).le.ntyp) then
2771             iti1 = itortyp(itype(i-1,1))
2772           else
2773             iti1=ntortyp+1
2774           endif
2775         else
2776           iti1=ntortyp+1
2777         endif
2778         do k=1,2
2779           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2780         enddo
2781 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2782 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2783 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2784 !d        write (iout,*) 'mu1',mu1(:,i-2)
2785 !d        write (iout,*) 'mu2',mu2(:,i-2)
2786         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2787         then
2788         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2789         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2790         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2791         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2792         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2793 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2794         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2795         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2796         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2797         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2798         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2799         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2800         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2801         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2802         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2803         endif
2804       enddo
2805 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2806 ! The order of matrices is from left to right.
2807       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2808       then
2809 !      do i=max0(ivec_start,2),ivec_end
2810       do i=2,nres-1
2811         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2812         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2813         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2814         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2815         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2816         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2817         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2818         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2819       enddo
2820       endif
2821 #if defined(MPI) && defined(PARMAT)
2822 #ifdef DEBUG
2823 !      if (fg_rank.eq.0) then
2824         write (iout,*) "Arrays UG and UGDER before GATHER"
2825         do i=1,nres-1
2826           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2827            ((ug(l,k,i),l=1,2),k=1,2),&
2828            ((ugder(l,k,i),l=1,2),k=1,2)
2829         enddo
2830         write (iout,*) "Arrays UG2 and UG2DER"
2831         do i=1,nres-1
2832           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2833            ((ug2(l,k,i),l=1,2),k=1,2),&
2834            ((ug2der(l,k,i),l=1,2),k=1,2)
2835         enddo
2836         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2837         do i=1,nres-1
2838           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2839            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2840            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2841         enddo
2842         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2843         do i=1,nres-1
2844           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2845            costab(i),sintab(i),costab2(i),sintab2(i)
2846         enddo
2847         write (iout,*) "Array MUDER"
2848         do i=1,nres-1
2849           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2850         enddo
2851 !      endif
2852 #endif
2853       if (nfgtasks.gt.1) then
2854         time00=MPI_Wtime()
2855 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2856 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2857 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2858 #ifdef MATGATHER
2859         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2860          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2861          FG_COMM1,IERR)
2862         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2863          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2864          FG_COMM1,IERR)
2865         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2866          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2867          FG_COMM1,IERR)
2868         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2869          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2870          FG_COMM1,IERR)
2871         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2872          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2873          FG_COMM1,IERR)
2874         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2875          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2876          FG_COMM1,IERR)
2877         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2878          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2879          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2880         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2881          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2882          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2883         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2884          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2885          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2886         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2887          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2888          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2889         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2890         then
2891         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2892          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2893          FG_COMM1,IERR)
2894         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2895          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2896          FG_COMM1,IERR)
2897         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2898          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2899          FG_COMM1,IERR)
2900        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2901          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2902          FG_COMM1,IERR)
2903         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2904          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2905          FG_COMM1,IERR)
2906         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2907          ivec_count(fg_rank1),&
2908          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2909          FG_COMM1,IERR)
2910         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2911          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2912          FG_COMM1,IERR)
2913         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2914          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2915          FG_COMM1,IERR)
2916         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2917          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2918          FG_COMM1,IERR)
2919         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2920          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2921          FG_COMM1,IERR)
2922         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2923          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2924          FG_COMM1,IERR)
2925         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2926          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2927          FG_COMM1,IERR)
2928         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2929          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2930          FG_COMM1,IERR)
2931         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2932          ivec_count(fg_rank1),&
2933          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2934          FG_COMM1,IERR)
2935         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2936          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2937          FG_COMM1,IERR)
2938        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2939          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2940          FG_COMM1,IERR)
2941         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2942          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2943          FG_COMM1,IERR)
2944        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2945          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2946          FG_COMM1,IERR)
2947         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2948          ivec_count(fg_rank1),&
2949          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2950          FG_COMM1,IERR)
2951         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2952          ivec_count(fg_rank1),&
2953          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2954          FG_COMM1,IERR)
2955         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2956          ivec_count(fg_rank1),&
2957          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2958          MPI_MAT2,FG_COMM1,IERR)
2959         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2960          ivec_count(fg_rank1),&
2961          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2962          MPI_MAT2,FG_COMM1,IERR)
2963         endif
2964 #else
2965 ! Passes matrix info through the ring
2966       isend=fg_rank1
2967       irecv=fg_rank1-1
2968       if (irecv.lt.0) irecv=nfgtasks1-1
2969       iprev=irecv
2970       inext=fg_rank1+1
2971       if (inext.ge.nfgtasks1) inext=0
2972       do i=1,nfgtasks1-1
2973 !        write (iout,*) "isend",isend," irecv",irecv
2974 !        call flush(iout)
2975         lensend=lentyp(isend)
2976         lenrecv=lentyp(irecv)
2977 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2978 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2979 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2980 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2981 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2982 !        write (iout,*) "Gather ROTAT1"
2983 !        call flush(iout)
2984 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2985 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2986 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2987 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2988 !        write (iout,*) "Gather ROTAT2"
2989 !        call flush(iout)
2990         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2991          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2992          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2993          iprev,4400+irecv,FG_COMM,status,IERR)
2994 !        write (iout,*) "Gather ROTAT_OLD"
2995 !        call flush(iout)
2996         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2997          MPI_PRECOMP11(lensend),inext,5500+isend,&
2998          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2999          iprev,5500+irecv,FG_COMM,status,IERR)
3000 !        write (iout,*) "Gather PRECOMP11"
3001 !        call flush(iout)
3002         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
3003          MPI_PRECOMP12(lensend),inext,6600+isend,&
3004          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
3005          iprev,6600+irecv,FG_COMM,status,IERR)
3006 !        write (iout,*) "Gather PRECOMP12"
3007 !        call flush(iout)
3008         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3009         then
3010         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
3011          MPI_ROTAT2(lensend),inext,7700+isend,&
3012          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
3013          iprev,7700+irecv,FG_COMM,status,IERR)
3014 !        write (iout,*) "Gather PRECOMP21"
3015 !        call flush(iout)
3016         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
3017          MPI_PRECOMP22(lensend),inext,8800+isend,&
3018          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
3019          iprev,8800+irecv,FG_COMM,status,IERR)
3020 !        write (iout,*) "Gather PRECOMP22"
3021 !        call flush(iout)
3022         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
3023          MPI_PRECOMP23(lensend),inext,9900+isend,&
3024          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
3025          MPI_PRECOMP23(lenrecv),&
3026          iprev,9900+irecv,FG_COMM,status,IERR)
3027 !        write (iout,*) "Gather PRECOMP23"
3028 !        call flush(iout)
3029         endif
3030         isend=irecv
3031         irecv=irecv-1
3032         if (irecv.lt.0) irecv=nfgtasks1-1
3033       enddo
3034 #endif
3035         time_gather=time_gather+MPI_Wtime()-time00
3036       endif
3037 #ifdef DEBUG
3038 !      if (fg_rank.eq.0) then
3039         write (iout,*) "Arrays UG and UGDER"
3040         do i=1,nres-1
3041           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3042            ((ug(l,k,i),l=1,2),k=1,2),&
3043            ((ugder(l,k,i),l=1,2),k=1,2)
3044         enddo
3045         write (iout,*) "Arrays UG2 and UG2DER"
3046         do i=1,nres-1
3047           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3048            ((ug2(l,k,i),l=1,2),k=1,2),&
3049            ((ug2der(l,k,i),l=1,2),k=1,2)
3050         enddo
3051         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3052         do i=1,nres-1
3053           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3054            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3055            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3056         enddo
3057         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3058         do i=1,nres-1
3059           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3060            costab(i),sintab(i),costab2(i),sintab2(i)
3061         enddo
3062         write (iout,*) "Array MUDER"
3063         do i=1,nres-1
3064           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3065         enddo
3066 !      endif
3067 #endif
3068 #endif
3069 !d      do i=1,nres
3070 !d        iti = itortyp(itype(i,1))
3071 !d        write (iout,*) i
3072 !d        do j=1,2
3073 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3074 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3075 !d        enddo
3076 !d      enddo
3077       return
3078       end subroutine set_matrices
3079 !-----------------------------------------------------------------------------
3080       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3081 !
3082 ! This subroutine calculates the average interaction energy and its gradient
3083 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
3084 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3085 ! The potential depends both on the distance of peptide-group centers and on
3086 ! the orientation of the CA-CA virtual bonds.
3087 !
3088       use comm_locel
3089 !      implicit real*8 (a-h,o-z)
3090 #ifdef MPI
3091       include 'mpif.h'
3092 #endif
3093 !      include 'DIMENSIONS'
3094 !      include 'COMMON.CONTROL'
3095 !      include 'COMMON.SETUP'
3096 !      include 'COMMON.IOUNITS'
3097 !      include 'COMMON.GEO'
3098 !      include 'COMMON.VAR'
3099 !      include 'COMMON.LOCAL'
3100 !      include 'COMMON.CHAIN'
3101 !      include 'COMMON.DERIV'
3102 !      include 'COMMON.INTERACT'
3103 !      include 'COMMON.CONTACTS'
3104 !      include 'COMMON.TORSION'
3105 !      include 'COMMON.VECTORS'
3106 !      include 'COMMON.FFIELD'
3107 !      include 'COMMON.TIME1'
3108       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
3109       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3110       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3111 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3112       real(kind=8),dimension(4) :: muij
3113 !el      integer :: num_conti,j1,j2
3114 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3115 !el        dz_normi,xmedi,ymedi,zmedi
3116
3117 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3118 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3119 !el          num_conti,j1,j2
3120
3121 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3122 #ifdef MOMENT
3123       real(kind=8) :: scal_el=1.0d0
3124 #else
3125       real(kind=8) :: scal_el=0.5d0
3126 #endif
3127 ! 12/13/98
3128 ! 13-go grudnia roku pamietnego...
3129       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3130                                              0.0d0,1.0d0,0.0d0,&
3131                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3132 !el local variables
3133       integer :: i,k,j
3134       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3135       real(kind=8) :: fac,t_eelecij,fracinbuf
3136
3137
3138 !d      write(iout,*) 'In EELEC'
3139 !        print *,"IN EELEC"
3140 !d      do i=1,nloctyp
3141 !d        write(iout,*) 'Type',i
3142 !d        write(iout,*) 'B1',B1(:,i)
3143 !d        write(iout,*) 'B2',B2(:,i)
3144 !d        write(iout,*) 'CC',CC(:,:,i)
3145 !d        write(iout,*) 'DD',DD(:,:,i)
3146 !d        write(iout,*) 'EE',EE(:,:,i)
3147 !d      enddo
3148 !d      call check_vecgrad
3149 !d      stop
3150 !      ees=0.0d0  !AS
3151 !      evdw1=0.0d0
3152 !      eel_loc=0.0d0
3153 !      eello_turn3=0.0d0
3154 !      eello_turn4=0.0d0
3155       t_eelecij=0.0d0
3156       ees=0.0D0
3157       evdw1=0.0D0
3158       eel_loc=0.0d0
3159       eello_turn3=0.0d0
3160       eello_turn4=0.0d0
3161 !
3162
3163       if (icheckgrad.eq.1) then
3164 !el
3165 !        do i=0,2*nres+2
3166 !          dc_norm(1,i)=0.0d0
3167 !          dc_norm(2,i)=0.0d0
3168 !          dc_norm(3,i)=0.0d0
3169 !        enddo
3170         do i=1,nres-1
3171           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3172           do k=1,3
3173             dc_norm(k,i)=dc(k,i)*fac
3174           enddo
3175 !          write (iout,*) 'i',i,' fac',fac
3176         enddo
3177       endif
3178 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3179 !        wturn6
3180       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3181           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3182           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3183 !        call vec_and_deriv
3184 #ifdef TIMING
3185         time01=MPI_Wtime()
3186 #endif
3187 !        print *, "before set matrices"
3188         call set_matrices
3189 !        print *, "after set matrices"
3190
3191 #ifdef TIMING
3192         time_mat=time_mat+MPI_Wtime()-time01
3193 #endif
3194       endif
3195 !       print *, "after set matrices"
3196 !d      do i=1,nres-1
3197 !d        write (iout,*) 'i=',i
3198 !d        do k=1,3
3199 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3200 !d        enddo
3201 !d        do k=1,3
3202 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3203 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3204 !d        enddo
3205 !d      enddo
3206       t_eelecij=0.0d0
3207       ees=0.0D0
3208       evdw1=0.0D0
3209       eel_loc=0.0d0
3210       eello_turn3=0.0d0
3211       eello_turn4=0.0d0
3212 !el      ind=0
3213       do i=1,nres
3214         num_cont_hb(i)=0
3215       enddo
3216 !d      print '(a)','Enter EELEC'
3217 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3218 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3219 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3220       do i=1,nres
3221         gel_loc_loc(i)=0.0d0
3222         gcorr_loc(i)=0.0d0
3223       enddo
3224 !
3225 !
3226 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3227 !
3228 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3229 !
3230
3231
3232 !        print *,"before iturn3 loop"
3233       do i=iturn3_start,iturn3_end
3234         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3235         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3236         dxi=dc(1,i)
3237         dyi=dc(2,i)
3238         dzi=dc(3,i)
3239         dx_normi=dc_norm(1,i)
3240         dy_normi=dc_norm(2,i)
3241         dz_normi=dc_norm(3,i)
3242         xmedi=c(1,i)+0.5d0*dxi
3243         ymedi=c(2,i)+0.5d0*dyi
3244         zmedi=c(3,i)+0.5d0*dzi
3245           xmedi=dmod(xmedi,boxxsize)
3246           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3247           ymedi=dmod(ymedi,boxysize)
3248           if (ymedi.lt.0) ymedi=ymedi+boxysize
3249           zmedi=dmod(zmedi,boxzsize)
3250           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3251         num_conti=0
3252        if ((zmedi.gt.bordlipbot) &
3253         .and.(zmedi.lt.bordliptop)) then
3254 !C the energy transfer exist
3255         if (zmedi.lt.buflipbot) then
3256 !C what fraction I am in
3257          fracinbuf=1.0d0- &
3258                ((zmedi-bordlipbot)/lipbufthick)
3259 !C lipbufthick is thickenes of lipid buffore
3260          sslipi=sscalelip(fracinbuf)
3261          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3262         elseif (zmedi.gt.bufliptop) then
3263          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3264          sslipi=sscalelip(fracinbuf)
3265          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3266         else
3267          sslipi=1.0d0
3268          ssgradlipi=0.0
3269         endif
3270        else
3271          sslipi=0.0d0
3272          ssgradlipi=0.0
3273        endif
3274 !       print *,i,sslipi,ssgradlipi
3275        call eelecij(i,i+2,ees,evdw1,eel_loc)
3276         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3277         num_cont_hb(i)=num_conti
3278       enddo
3279       do i=iturn4_start,iturn4_end
3280         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3281           .or. itype(i+3,1).eq.ntyp1 &
3282           .or. itype(i+4,1).eq.ntyp1) cycle
3283 !        print *,"before2",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3284         dxi=dc(1,i)
3285         dyi=dc(2,i)
3286         dzi=dc(3,i)
3287         dx_normi=dc_norm(1,i)
3288         dy_normi=dc_norm(2,i)
3289         dz_normi=dc_norm(3,i)
3290         xmedi=c(1,i)+0.5d0*dxi
3291         ymedi=c(2,i)+0.5d0*dyi
3292         zmedi=c(3,i)+0.5d0*dzi
3293           xmedi=dmod(xmedi,boxxsize)
3294           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3295           ymedi=dmod(ymedi,boxysize)
3296           if (ymedi.lt.0) ymedi=ymedi+boxysize
3297           zmedi=dmod(zmedi,boxzsize)
3298           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3299        if ((zmedi.gt.bordlipbot)  &
3300        .and.(zmedi.lt.bordliptop)) then
3301 !C the energy transfer exist
3302         if (zmedi.lt.buflipbot) then
3303 !C what fraction I am in
3304          fracinbuf=1.0d0- &
3305              ((zmedi-bordlipbot)/lipbufthick)
3306 !C lipbufthick is thickenes of lipid buffore
3307          sslipi=sscalelip(fracinbuf)
3308          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3309         elseif (zmedi.gt.bufliptop) then
3310          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3311          sslipi=sscalelip(fracinbuf)
3312          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3313         else
3314          sslipi=1.0d0
3315          ssgradlipi=0.0
3316         endif
3317        else
3318          sslipi=0.0d0
3319          ssgradlipi=0.0
3320        endif
3321
3322         num_conti=num_cont_hb(i)
3323         call eelecij(i,i+3,ees,evdw1,eel_loc)
3324         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3325          call eturn4(i,eello_turn4)
3326 !        print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3327         num_cont_hb(i)=num_conti
3328       enddo   ! i
3329 !
3330 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3331 !
3332 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3333       do i=iatel_s,iatel_e
3334         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3335         dxi=dc(1,i)
3336         dyi=dc(2,i)
3337         dzi=dc(3,i)
3338         dx_normi=dc_norm(1,i)
3339         dy_normi=dc_norm(2,i)
3340         dz_normi=dc_norm(3,i)
3341         xmedi=c(1,i)+0.5d0*dxi
3342         ymedi=c(2,i)+0.5d0*dyi
3343         zmedi=c(3,i)+0.5d0*dzi
3344           xmedi=dmod(xmedi,boxxsize)
3345           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3346           ymedi=dmod(ymedi,boxysize)
3347           if (ymedi.lt.0) ymedi=ymedi+boxysize
3348           zmedi=dmod(zmedi,boxzsize)
3349           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3350        if ((zmedi.gt.bordlipbot)  &
3351         .and.(zmedi.lt.bordliptop)) then
3352 !C the energy transfer exist
3353         if (zmedi.lt.buflipbot) then
3354 !C what fraction I am in
3355          fracinbuf=1.0d0- &
3356              ((zmedi-bordlipbot)/lipbufthick)
3357 !C lipbufthick is thickenes of lipid buffore
3358          sslipi=sscalelip(fracinbuf)
3359          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3360         elseif (zmedi.gt.bufliptop) then
3361          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3362          sslipi=sscalelip(fracinbuf)
3363          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3364         else
3365          sslipi=1.0d0
3366          ssgradlipi=0.0
3367         endif
3368        else
3369          sslipi=0.0d0
3370          ssgradlipi=0.0
3371        endif
3372
3373 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3374         num_conti=num_cont_hb(i)
3375         do j=ielstart(i),ielend(i)
3376 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3377           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3378           call eelecij(i,j,ees,evdw1,eel_loc)
3379         enddo ! j
3380         num_cont_hb(i)=num_conti
3381       enddo   ! i
3382 !      write (iout,*) "Number of loop steps in EELEC:",ind
3383 !d      do i=1,nres
3384 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3385 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3386 !d      enddo
3387 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3388 !cc      eel_loc=eel_loc+eello_turn3
3389 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3390       return
3391       end subroutine eelec
3392 !-----------------------------------------------------------------------------
3393       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3394
3395       use comm_locel
3396 !      implicit real*8 (a-h,o-z)
3397 !      include 'DIMENSIONS'
3398 #ifdef MPI
3399       include "mpif.h"
3400 #endif
3401 !      include 'COMMON.CONTROL'
3402 !      include 'COMMON.IOUNITS'
3403 !      include 'COMMON.GEO'
3404 !      include 'COMMON.VAR'
3405 !      include 'COMMON.LOCAL'
3406 !      include 'COMMON.CHAIN'
3407 !      include 'COMMON.DERIV'
3408 !      include 'COMMON.INTERACT'
3409 !      include 'COMMON.CONTACTS'
3410 !      include 'COMMON.TORSION'
3411 !      include 'COMMON.VECTORS'
3412 !      include 'COMMON.FFIELD'
3413 !      include 'COMMON.TIME1'
3414       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3415       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3416       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3417 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3418       real(kind=8),dimension(4) :: muij
3419       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3420                     dist_temp, dist_init,rlocshield,fracinbuf
3421       integer xshift,yshift,zshift,ilist,iresshield
3422 !el      integer :: num_conti,j1,j2
3423 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3424 !el        dz_normi,xmedi,ymedi,zmedi
3425
3426 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3427 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3428 !el          num_conti,j1,j2
3429
3430 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3431 #ifdef MOMENT
3432       real(kind=8) :: scal_el=1.0d0
3433 #else
3434       real(kind=8) :: scal_el=0.5d0
3435 #endif
3436 ! 12/13/98
3437 ! 13-go grudnia roku pamietnego...
3438       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3439                                              0.0d0,1.0d0,0.0d0,&
3440                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3441 !      integer :: maxconts=nres/4
3442 !el local variables
3443       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3444       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3445       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3446       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3447                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3448                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3449                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3450                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3451                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3452                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3453                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3454 !      maxconts=nres/4
3455 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3456 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3457
3458 !          time00=MPI_Wtime()
3459 !d      write (iout,*) "eelecij",i,j
3460 !          ind=ind+1
3461           iteli=itel(i)
3462           itelj=itel(j)
3463           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3464           aaa=app(iteli,itelj)
3465           bbb=bpp(iteli,itelj)
3466           ael6i=ael6(iteli,itelj)
3467           ael3i=ael3(iteli,itelj)
3468           dxj=dc(1,j)
3469           dyj=dc(2,j)
3470           dzj=dc(3,j)
3471           dx_normj=dc_norm(1,j)
3472           dy_normj=dc_norm(2,j)
3473           dz_normj=dc_norm(3,j)
3474 !          xj=c(1,j)+0.5D0*dxj-xmedi
3475 !          yj=c(2,j)+0.5D0*dyj-ymedi
3476 !          zj=c(3,j)+0.5D0*dzj-zmedi
3477           xj=c(1,j)+0.5D0*dxj
3478           yj=c(2,j)+0.5D0*dyj
3479           zj=c(3,j)+0.5D0*dzj
3480           xj=mod(xj,boxxsize)
3481           if (xj.lt.0) xj=xj+boxxsize
3482           yj=mod(yj,boxysize)
3483           if (yj.lt.0) yj=yj+boxysize
3484           zj=mod(zj,boxzsize)
3485           if (zj.lt.0) zj=zj+boxzsize
3486        if ((zj.gt.bordlipbot)  &
3487        .and.(zj.lt.bordliptop)) then
3488 !C the energy transfer exist
3489         if (zj.lt.buflipbot) then
3490 !C what fraction I am in
3491          fracinbuf=1.0d0-     &
3492              ((zj-bordlipbot)/lipbufthick)
3493 !C lipbufthick is thickenes of lipid buffore
3494          sslipj=sscalelip(fracinbuf)
3495          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3496         elseif (zj.gt.bufliptop) then
3497          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3498          sslipj=sscalelip(fracinbuf)
3499          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3500         else
3501          sslipj=1.0d0
3502          ssgradlipj=0.0
3503         endif
3504        else
3505          sslipj=0.0d0
3506          ssgradlipj=0.0
3507        endif
3508
3509       isubchap=0
3510       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3511       xj_safe=xj
3512       yj_safe=yj
3513       zj_safe=zj
3514       do xshift=-1,1
3515       do yshift=-1,1
3516       do zshift=-1,1
3517           xj=xj_safe+xshift*boxxsize
3518           yj=yj_safe+yshift*boxysize
3519           zj=zj_safe+zshift*boxzsize
3520           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3521           if(dist_temp.lt.dist_init) then
3522             dist_init=dist_temp
3523             xj_temp=xj
3524             yj_temp=yj
3525             zj_temp=zj
3526             isubchap=1
3527           endif
3528        enddo
3529        enddo
3530        enddo
3531        if (isubchap.eq.1) then
3532 !C          print *,i,j
3533           xj=xj_temp-xmedi
3534           yj=yj_temp-ymedi
3535           zj=zj_temp-zmedi
3536        else
3537           xj=xj_safe-xmedi
3538           yj=yj_safe-ymedi
3539           zj=zj_safe-zmedi
3540        endif
3541
3542           rij=xj*xj+yj*yj+zj*zj
3543           rrmij=1.0D0/rij
3544           rij=dsqrt(rij)
3545 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3546             sss_ele_cut=sscale_ele(rij)
3547             sss_ele_grad=sscagrad_ele(rij)
3548 !             sss_ele_cut=1.0d0
3549 !             sss_ele_grad=0.0d0
3550 !            print *,sss_ele_cut,sss_ele_grad,&
3551 !            (rij),r_cut_ele,rlamb_ele
3552 !            if (sss_ele_cut.le.0.0) go to 128
3553
3554           rmij=1.0D0/rij
3555           r3ij=rrmij*rmij
3556           r6ij=r3ij*r3ij
3557           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3558           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3559           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3560           fac=cosa-3.0D0*cosb*cosg
3561           ev1=aaa*r6ij*r6ij
3562 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3563           if (j.eq.i+2) ev1=scal_el*ev1
3564           ev2=bbb*r6ij
3565           fac3=ael6i*r6ij
3566           fac4=ael3i*r3ij
3567           evdwij=ev1+ev2
3568           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3569           el2=fac4*fac
3570 !          eesij=el1+el2
3571           if (shield_mode.gt.0) then
3572 !C          fac_shield(i)=0.4
3573 !C          fac_shield(j)=0.6
3574           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3575           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3576           eesij=(el1+el2)
3577           ees=ees+eesij*sss_ele_cut
3578 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3579 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3580           else
3581           fac_shield(i)=1.0
3582           fac_shield(j)=1.0
3583           eesij=(el1+el2)
3584           ees=ees+eesij   &
3585             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3586 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3587           endif
3588
3589 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3590           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3591 !          ees=ees+eesij*sss_ele_cut
3592           evdw1=evdw1+evdwij*sss_ele_cut  &
3593            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3594 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3595 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3596 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3597 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3598
3599           if (energy_dec) then
3600 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3601 !                  'evdw1',i,j,evdwij,&
3602 !                  iteli,itelj,aaa,evdw1
3603               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3604               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3605           endif
3606 !
3607 ! Calculate contributions to the Cartesian gradient.
3608 !
3609 #ifdef SPLITELE
3610           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3611               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3612           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3613              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3614           fac1=fac
3615           erij(1)=xj*rmij
3616           erij(2)=yj*rmij
3617           erij(3)=zj*rmij
3618 !
3619 ! Radial derivatives. First process both termini of the fragment (i,j)
3620 !
3621           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3622           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3623           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3624            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3625           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3626             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3627
3628           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3629           (shield_mode.gt.0)) then
3630 !C          print *,i,j
3631           do ilist=1,ishield_list(i)
3632            iresshield=shield_list(ilist,i)
3633            do k=1,3
3634            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3635            *2.0*sss_ele_cut
3636            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3637                    rlocshield &
3638             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3639             *sss_ele_cut
3640             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3641            enddo
3642           enddo
3643           do ilist=1,ishield_list(j)
3644            iresshield=shield_list(ilist,j)
3645            do k=1,3
3646            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3647           *2.0*sss_ele_cut
3648            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3649                    rlocshield &
3650            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3651            *sss_ele_cut
3652            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3653            enddo
3654           enddo
3655           do k=1,3
3656             gshieldc(k,i)=gshieldc(k,i)+ &
3657                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3658            *sss_ele_cut
3659
3660             gshieldc(k,j)=gshieldc(k,j)+ &
3661                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3662            *sss_ele_cut
3663
3664             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3665                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3666            *sss_ele_cut
3667
3668             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3669                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3670            *sss_ele_cut
3671
3672            enddo
3673            endif
3674
3675
3676 !          do k=1,3
3677 !            ghalf=0.5D0*ggg(k)
3678 !            gelc(k,i)=gelc(k,i)+ghalf
3679 !            gelc(k,j)=gelc(k,j)+ghalf
3680 !          enddo
3681 ! 9/28/08 AL Gradient compotents will be summed only at the end
3682           do k=1,3
3683             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3684             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3685           enddo
3686             gelc_long(3,j)=gelc_long(3,j)+  &
3687           ssgradlipj*eesij/2.0d0*lipscale**2&
3688            *sss_ele_cut
3689
3690             gelc_long(3,i)=gelc_long(3,i)+  &
3691           ssgradlipi*eesij/2.0d0*lipscale**2&
3692            *sss_ele_cut
3693
3694
3695 !
3696 ! Loop over residues i+1 thru j-1.
3697 !
3698 !grad          do k=i+1,j-1
3699 !grad            do l=1,3
3700 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3701 !grad            enddo
3702 !grad          enddo
3703           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3704            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3705           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3706            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3707           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3708            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3709
3710 !          do k=1,3
3711 !            ghalf=0.5D0*ggg(k)
3712 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3713 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3714 !          enddo
3715 ! 9/28/08 AL Gradient compotents will be summed only at the end
3716           do k=1,3
3717             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3718             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3719           enddo
3720
3721 !C Lipidic part for scaling weight
3722            gvdwpp(3,j)=gvdwpp(3,j)+ &
3723           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3724            gvdwpp(3,i)=gvdwpp(3,i)+ &
3725           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3726 !! Loop over residues i+1 thru j-1.
3727 !
3728 !grad          do k=i+1,j-1
3729 !grad            do l=1,3
3730 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3731 !grad            enddo
3732 !grad          enddo
3733 #else
3734           facvdw=(ev1+evdwij)*sss_ele_cut &
3735            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3736
3737           facel=(el1+eesij)*sss_ele_cut
3738           fac1=fac
3739           fac=-3*rrmij*(facvdw+facvdw+facel)
3740           erij(1)=xj*rmij
3741           erij(2)=yj*rmij
3742           erij(3)=zj*rmij
3743 !
3744 ! Radial derivatives. First process both termini of the fragment (i,j)
3745 !
3746           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3747           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3748           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3749 !          do k=1,3
3750 !            ghalf=0.5D0*ggg(k)
3751 !            gelc(k,i)=gelc(k,i)+ghalf
3752 !            gelc(k,j)=gelc(k,j)+ghalf
3753 !          enddo
3754 ! 9/28/08 AL Gradient compotents will be summed only at the end
3755           do k=1,3
3756             gelc_long(k,j)=gelc(k,j)+ggg(k)
3757             gelc_long(k,i)=gelc(k,i)-ggg(k)
3758           enddo
3759 !
3760 ! Loop over residues i+1 thru j-1.
3761 !
3762 !grad          do k=i+1,j-1
3763 !grad            do l=1,3
3764 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3765 !grad            enddo
3766 !grad          enddo
3767 ! 9/28/08 AL Gradient compotents will be summed only at the end
3768           ggg(1)=facvdw*xj &
3769            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3770           ggg(2)=facvdw*yj &
3771            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3772           ggg(3)=facvdw*zj &
3773            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3774
3775           do k=1,3
3776             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3777             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3778           enddo
3779            gvdwpp(3,j)=gvdwpp(3,j)+ &
3780           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3781            gvdwpp(3,i)=gvdwpp(3,i)+ &
3782           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3783
3784 #endif
3785 !
3786 ! Angular part
3787 !
3788           ecosa=2.0D0*fac3*fac1+fac4
3789           fac4=-3.0D0*fac4
3790           fac3=-6.0D0*fac3
3791           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3792           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3793           do k=1,3
3794             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3795             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3796           enddo
3797 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3798 !d   &          (dcosg(k),k=1,3)
3799           do k=1,3
3800             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3801              *fac_shield(i)**2*fac_shield(j)**2 &
3802              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3803
3804           enddo
3805 !          do k=1,3
3806 !            ghalf=0.5D0*ggg(k)
3807 !            gelc(k,i)=gelc(k,i)+ghalf
3808 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3809 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3810 !            gelc(k,j)=gelc(k,j)+ghalf
3811 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3812 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3813 !          enddo
3814 !grad          do k=i+1,j-1
3815 !grad            do l=1,3
3816 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3817 !grad            enddo
3818 !grad          enddo
3819           do k=1,3
3820             gelc(k,i)=gelc(k,i) &
3821                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3822                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3823                      *sss_ele_cut &
3824                      *fac_shield(i)**2*fac_shield(j)**2 &
3825                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3826
3827             gelc(k,j)=gelc(k,j) &
3828                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3829                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3830                      *sss_ele_cut  &
3831                      *fac_shield(i)**2*fac_shield(j)**2  &
3832                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3833
3834             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3835             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3836           enddo
3837
3838           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3839               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3840               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3841 !
3842 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3843 !   energy of a peptide unit is assumed in the form of a second-order
3844 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3845 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3846 !   are computed for EVERY pair of non-contiguous peptide groups.
3847 !
3848           if (j.lt.nres-1) then
3849             j1=j+1
3850             j2=j-1
3851           else
3852             j1=j-1
3853             j2=j-2
3854           endif
3855           kkk=0
3856           do k=1,2
3857             do l=1,2
3858               kkk=kkk+1
3859               muij(kkk)=mu(k,i)*mu(l,j)
3860             enddo
3861           enddo
3862 !d         write (iout,*) 'EELEC: i',i,' j',j
3863 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3864 !d          write(iout,*) 'muij',muij
3865           ury=scalar(uy(1,i),erij)
3866           urz=scalar(uz(1,i),erij)
3867           vry=scalar(uy(1,j),erij)
3868           vrz=scalar(uz(1,j),erij)
3869           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3870           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3871           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3872           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3873           fac=dsqrt(-ael6i)*r3ij
3874           a22=a22*fac
3875           a23=a23*fac
3876           a32=a32*fac
3877           a33=a33*fac
3878 !d          write (iout,'(4i5,4f10.5)')
3879 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
3880 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3881 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3882 !d     &      uy(:,j),uz(:,j)
3883 !d          write (iout,'(4f10.5)')
3884 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3885 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3886 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3887 !d           write (iout,'(9f10.5/)')
3888 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3889 ! Derivatives of the elements of A in virtual-bond vectors
3890           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3891           do k=1,3
3892             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3893             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3894             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3895             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3896             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3897             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3898             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3899             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3900             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3901             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3902             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3903             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3904           enddo
3905 ! Compute radial contributions to the gradient
3906           facr=-3.0d0*rrmij
3907           a22der=a22*facr
3908           a23der=a23*facr
3909           a32der=a32*facr
3910           a33der=a33*facr
3911           agg(1,1)=a22der*xj
3912           agg(2,1)=a22der*yj
3913           agg(3,1)=a22der*zj
3914           agg(1,2)=a23der*xj
3915           agg(2,2)=a23der*yj
3916           agg(3,2)=a23der*zj
3917           agg(1,3)=a32der*xj
3918           agg(2,3)=a32der*yj
3919           agg(3,3)=a32der*zj
3920           agg(1,4)=a33der*xj
3921           agg(2,4)=a33der*yj
3922           agg(3,4)=a33der*zj
3923 ! Add the contributions coming from er
3924           fac3=-3.0d0*fac
3925           do k=1,3
3926             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3927             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3928             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3929             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3930           enddo
3931           do k=1,3
3932 ! Derivatives in DC(i)
3933 !grad            ghalf1=0.5d0*agg(k,1)
3934 !grad            ghalf2=0.5d0*agg(k,2)
3935 !grad            ghalf3=0.5d0*agg(k,3)
3936 !grad            ghalf4=0.5d0*agg(k,4)
3937             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3938             -3.0d0*uryg(k,2)*vry)!+ghalf1
3939             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3940             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3941             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3942             -3.0d0*urzg(k,2)*vry)!+ghalf3
3943             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3944             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3945 ! Derivatives in DC(i+1)
3946             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3947             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3948             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3949             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3950             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3951             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3952             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3953             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3954 ! Derivatives in DC(j)
3955             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3956             -3.0d0*vryg(k,2)*ury)!+ghalf1
3957             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3958             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3959             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3960             -3.0d0*vryg(k,2)*urz)!+ghalf3
3961             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3962             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3963 ! Derivatives in DC(j+1) or DC(nres-1)
3964             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3965             -3.0d0*vryg(k,3)*ury)
3966             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3967             -3.0d0*vrzg(k,3)*ury)
3968             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3969             -3.0d0*vryg(k,3)*urz)
3970             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3971             -3.0d0*vrzg(k,3)*urz)
3972 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3973 !grad              do l=1,4
3974 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3975 !grad              enddo
3976 !grad            endif
3977           enddo
3978           acipa(1,1)=a22
3979           acipa(1,2)=a23
3980           acipa(2,1)=a32
3981           acipa(2,2)=a33
3982           a22=-a22
3983           a23=-a23
3984           do l=1,2
3985             do k=1,3
3986               agg(k,l)=-agg(k,l)
3987               aggi(k,l)=-aggi(k,l)
3988               aggi1(k,l)=-aggi1(k,l)
3989               aggj(k,l)=-aggj(k,l)
3990               aggj1(k,l)=-aggj1(k,l)
3991             enddo
3992           enddo
3993           if (j.lt.nres-1) then
3994             a22=-a22
3995             a32=-a32
3996             do l=1,3,2
3997               do k=1,3
3998                 agg(k,l)=-agg(k,l)
3999                 aggi(k,l)=-aggi(k,l)
4000                 aggi1(k,l)=-aggi1(k,l)
4001                 aggj(k,l)=-aggj(k,l)
4002                 aggj1(k,l)=-aggj1(k,l)
4003               enddo
4004             enddo
4005           else
4006             a22=-a22
4007             a23=-a23
4008             a32=-a32
4009             a33=-a33
4010             do l=1,4
4011               do k=1,3
4012                 agg(k,l)=-agg(k,l)
4013                 aggi(k,l)=-aggi(k,l)
4014                 aggi1(k,l)=-aggi1(k,l)
4015                 aggj(k,l)=-aggj(k,l)
4016                 aggj1(k,l)=-aggj1(k,l)
4017               enddo
4018             enddo
4019           endif
4020           ENDIF ! WCORR
4021           IF (wel_loc.gt.0.0d0) THEN
4022 ! Contribution to the local-electrostatic energy coming from the i-j pair
4023           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
4024            +a33*muij(4)
4025           if (shield_mode.eq.0) then
4026            fac_shield(i)=1.0
4027            fac_shield(j)=1.0
4028           endif
4029           eel_loc_ij=eel_loc_ij &
4030          *fac_shield(i)*fac_shield(j) &
4031          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4032 !C Now derivative over eel_loc
4033           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
4034          (shield_mode.gt.0)) then
4035 !C          print *,i,j
4036
4037           do ilist=1,ishield_list(i)
4038            iresshield=shield_list(ilist,i)
4039            do k=1,3
4040            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
4041                                                 /fac_shield(i)&
4042            *sss_ele_cut
4043            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4044                    rlocshield  &
4045           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
4046           *sss_ele_cut
4047
4048             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4049            +rlocshield
4050            enddo
4051           enddo
4052           do ilist=1,ishield_list(j)
4053            iresshield=shield_list(ilist,j)
4054            do k=1,3
4055            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
4056                                             /fac_shield(j)   &
4057             *sss_ele_cut
4058            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4059                    rlocshield  &
4060       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
4061        *sss_ele_cut
4062
4063            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4064                   +rlocshield
4065
4066            enddo
4067           enddo
4068
4069           do k=1,3
4070             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
4071                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4072                     *sss_ele_cut
4073             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
4074                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4075                     *sss_ele_cut
4076             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
4077                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4078                     *sss_ele_cut
4079             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
4080                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4081                     *sss_ele_cut
4082
4083            enddo
4084            endif
4085
4086
4087 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4088 !           eel_loc_ij=0.0
4089 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4090 !                  'eelloc',i,j,eel_loc_ij
4091           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
4092                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4093 !           print *,"EELLOC",i,gel_loc_loc(i-1)
4094
4095 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4096 !          if (energy_dec) write (iout,*) "muij",muij
4097 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
4098
4099           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
4100 ! Partial derivatives in virtual-bond dihedral angles gamma
4101           if (i.gt.1) &
4102           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
4103                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
4104                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
4105                  *sss_ele_cut  &
4106           *fac_shield(i)*fac_shield(j) &
4107           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4108
4109           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
4110                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
4111                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
4112                  *sss_ele_cut &
4113           *fac_shield(i)*fac_shield(j) &
4114           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4115 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4116 !          do l=1,3
4117 !            ggg(1)=(agg(1,1)*muij(1)+ &
4118 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
4119 !            *sss_ele_cut &
4120 !             +eel_loc_ij*sss_ele_grad*rmij*xj
4121 !            ggg(2)=(agg(2,1)*muij(1)+ &
4122 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4123 !            *sss_ele_cut &
4124 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4125 !            ggg(3)=(agg(3,1)*muij(1)+ &
4126 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4127 !            *sss_ele_cut &
4128 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4129            xtemp(1)=xj
4130            xtemp(2)=yj
4131            xtemp(3)=zj
4132
4133            do l=1,3
4134             ggg(l)=(agg(l,1)*muij(1)+ &
4135                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4136             *sss_ele_cut &
4137           *fac_shield(i)*fac_shield(j) &
4138           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4139              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4140
4141
4142             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4143             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4144 !grad            ghalf=0.5d0*ggg(l)
4145 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4146 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4147           enddo
4148             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4149           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4150           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4151
4152             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4153           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4154           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4155
4156 !grad          do k=i+1,j2
4157 !grad            do l=1,3
4158 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4159 !grad            enddo
4160 !grad          enddo
4161 ! Remaining derivatives of eello
4162           do l=1,3
4163             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4164                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4165             *sss_ele_cut &
4166           *fac_shield(i)*fac_shield(j) &
4167           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4168
4169 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4170             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4171                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4172             +aggi1(l,4)*muij(4))&
4173             *sss_ele_cut &
4174           *fac_shield(i)*fac_shield(j) &
4175           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4176
4177 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4178             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4179                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4180             *sss_ele_cut &
4181           *fac_shield(i)*fac_shield(j) &
4182           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4183
4184 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4185             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4186                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4187             +aggj1(l,4)*muij(4))&
4188             *sss_ele_cut &
4189           *fac_shield(i)*fac_shield(j) &
4190          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4191
4192 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4193           enddo
4194           ENDIF
4195 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4196 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4197           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4198              .and. num_conti.le.maxconts) then
4199 !            write (iout,*) i,j," entered corr"
4200 !
4201 ! Calculate the contact function. The ith column of the array JCONT will
4202 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4203 ! greater than I). The arrays FACONT and GACONT will contain the values of
4204 ! the contact function and its derivative.
4205 !           r0ij=1.02D0*rpp(iteli,itelj)
4206 !           r0ij=1.11D0*rpp(iteli,itelj)
4207             r0ij=2.20D0*rpp(iteli,itelj)
4208 !           r0ij=1.55D0*rpp(iteli,itelj)
4209             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4210 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4211             if (fcont.gt.0.0D0) then
4212               num_conti=num_conti+1
4213               if (num_conti.gt.maxconts) then
4214 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4215 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4216                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4217                                ' will skip next contacts for this conf.', num_conti
4218               else
4219                 jcont_hb(num_conti,i)=j
4220 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4221 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4222                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4223                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4224 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4225 !  terms.
4226                 d_cont(num_conti,i)=rij
4227 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4228 !     --- Electrostatic-interaction matrix ---
4229                 a_chuj(1,1,num_conti,i)=a22
4230                 a_chuj(1,2,num_conti,i)=a23
4231                 a_chuj(2,1,num_conti,i)=a32
4232                 a_chuj(2,2,num_conti,i)=a33
4233 !     --- Gradient of rij
4234                 do kkk=1,3
4235                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4236                 enddo
4237                 kkll=0
4238                 do k=1,2
4239                   do l=1,2
4240                     kkll=kkll+1
4241                     do m=1,3
4242                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4243                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4244                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4245                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4246                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4247                     enddo
4248                   enddo
4249                 enddo
4250                 ENDIF
4251                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4252 ! Calculate contact energies
4253                 cosa4=4.0D0*cosa
4254                 wij=cosa-3.0D0*cosb*cosg
4255                 cosbg1=cosb+cosg
4256                 cosbg2=cosb-cosg
4257 !               fac3=dsqrt(-ael6i)/r0ij**3
4258                 fac3=dsqrt(-ael6i)*r3ij
4259 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4260                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4261                 if (ees0tmp.gt.0) then
4262                   ees0pij=dsqrt(ees0tmp)
4263                 else
4264                   ees0pij=0
4265                 endif
4266                 if (shield_mode.eq.0) then
4267                 fac_shield(i)=1.0d0
4268                 fac_shield(j)=1.0d0
4269                 else
4270                 ees0plist(num_conti,i)=j
4271                 endif
4272 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4273                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4274                 if (ees0tmp.gt.0) then
4275                   ees0mij=dsqrt(ees0tmp)
4276                 else
4277                   ees0mij=0
4278                 endif
4279 !               ees0mij=0.0D0
4280                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4281                      *sss_ele_cut &
4282                      *fac_shield(i)*fac_shield(j)
4283
4284                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4285                      *sss_ele_cut &
4286                      *fac_shield(i)*fac_shield(j)
4287
4288 ! Diagnostics. Comment out or remove after debugging!
4289 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4290 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4291 !               ees0m(num_conti,i)=0.0D0
4292 ! End diagnostics.
4293 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4294 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4295 ! Angular derivatives of the contact function
4296                 ees0pij1=fac3/ees0pij
4297                 ees0mij1=fac3/ees0mij
4298                 fac3p=-3.0D0*fac3*rrmij
4299                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4300                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4301 !               ees0mij1=0.0D0
4302                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4303                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4304                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4305                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4306                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4307                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4308                 ecosap=ecosa1+ecosa2
4309                 ecosbp=ecosb1+ecosb2
4310                 ecosgp=ecosg1+ecosg2
4311                 ecosam=ecosa1-ecosa2
4312                 ecosbm=ecosb1-ecosb2
4313                 ecosgm=ecosg1-ecosg2
4314 ! Diagnostics
4315 !               ecosap=ecosa1
4316 !               ecosbp=ecosb1
4317 !               ecosgp=ecosg1
4318 !               ecosam=0.0D0
4319 !               ecosbm=0.0D0
4320 !               ecosgm=0.0D0
4321 ! End diagnostics
4322                 facont_hb(num_conti,i)=fcont
4323                 fprimcont=fprimcont/rij
4324 !d              facont_hb(num_conti,i)=1.0D0
4325 ! Following line is for diagnostics.
4326 !d              fprimcont=0.0D0
4327                 do k=1,3
4328                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4329                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4330                 enddo
4331                 do k=1,3
4332                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4333                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4334                 enddo
4335                 gggp(1)=gggp(1)+ees0pijp*xj &
4336                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4337                 gggp(2)=gggp(2)+ees0pijp*yj &
4338                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4339                 gggp(3)=gggp(3)+ees0pijp*zj &
4340                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4341
4342                 gggm(1)=gggm(1)+ees0mijp*xj &
4343                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4344
4345                 gggm(2)=gggm(2)+ees0mijp*yj &
4346                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4347
4348                 gggm(3)=gggm(3)+ees0mijp*zj &
4349                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4350
4351 ! Derivatives due to the contact function
4352                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4353                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4354                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4355                 do k=1,3
4356 !
4357 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4358 !          following the change of gradient-summation algorithm.
4359 !
4360 !grad                  ghalfp=0.5D0*gggp(k)
4361 !grad                  ghalfm=0.5D0*gggm(k)
4362                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4363                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4364                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4365                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4366
4367                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4368                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4369                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4370                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4371
4372                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4373                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4374
4375                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4376                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4377                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4378                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4379
4380                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4381                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4382                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4383                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4384
4385                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4386                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4387
4388                 enddo
4389 ! Diagnostics. Comment out or remove after debugging!
4390 !diag           do k=1,3
4391 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4392 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4393 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4394 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4395 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4396 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4397 !diag           enddo
4398               ENDIF ! wcorr
4399               endif  ! num_conti.le.maxconts
4400             endif  ! fcont.gt.0
4401           endif    ! j.gt.i+1
4402           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4403             do k=1,4
4404               do l=1,3
4405                 ghalf=0.5d0*agg(l,k)
4406                 aggi(l,k)=aggi(l,k)+ghalf
4407                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4408                 aggj(l,k)=aggj(l,k)+ghalf
4409               enddo
4410             enddo
4411             if (j.eq.nres-1 .and. i.lt.j-2) then
4412               do k=1,4
4413                 do l=1,3
4414                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4415                 enddo
4416               enddo
4417             endif
4418           endif
4419  128  continue
4420 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4421       return
4422       end subroutine eelecij
4423 !-----------------------------------------------------------------------------
4424       subroutine eturn3(i,eello_turn3)
4425 ! Third- and fourth-order contributions from turns
4426
4427       use comm_locel
4428 !      implicit real*8 (a-h,o-z)
4429 !      include 'DIMENSIONS'
4430 !      include 'COMMON.IOUNITS'
4431 !      include 'COMMON.GEO'
4432 !      include 'COMMON.VAR'
4433 !      include 'COMMON.LOCAL'
4434 !      include 'COMMON.CHAIN'
4435 !      include 'COMMON.DERIV'
4436 !      include 'COMMON.INTERACT'
4437 !      include 'COMMON.CONTACTS'
4438 !      include 'COMMON.TORSION'
4439 !      include 'COMMON.VECTORS'
4440 !      include 'COMMON.FFIELD'
4441 !      include 'COMMON.CONTROL'
4442       real(kind=8),dimension(3) :: ggg
4443       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4444         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4445       real(kind=8),dimension(2) :: auxvec,auxvec1
4446 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4447       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4448 !el      integer :: num_conti,j1,j2
4449 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4450 !el        dz_normi,xmedi,ymedi,zmedi
4451
4452 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4453 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4454 !el         num_conti,j1,j2
4455 !el local variables
4456       integer :: i,j,l,k,ilist,iresshield
4457       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4458
4459       j=i+2
4460 !      write (iout,*) "eturn3",i,j,j1,j2
4461           zj=(c(3,j)+c(3,j+1))/2.0d0
4462           zj=mod(zj,boxzsize)
4463           if (zj.lt.0) zj=zj+boxzsize
4464           if ((zj.lt.0)) write (*,*) "CHUJ"
4465        if ((zj.gt.bordlipbot)  &
4466         .and.(zj.lt.bordliptop)) then
4467 !C the energy transfer exist
4468         if (zj.lt.buflipbot) then
4469 !C what fraction I am in
4470          fracinbuf=1.0d0-     &
4471              ((zj-bordlipbot)/lipbufthick)
4472 !C lipbufthick is thickenes of lipid buffore
4473          sslipj=sscalelip(fracinbuf)
4474          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4475         elseif (zj.gt.bufliptop) then
4476          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4477          sslipj=sscalelip(fracinbuf)
4478          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4479         else
4480          sslipj=1.0d0
4481          ssgradlipj=0.0
4482         endif
4483        else
4484          sslipj=0.0d0
4485          ssgradlipj=0.0
4486        endif
4487
4488       a_temp(1,1)=a22
4489       a_temp(1,2)=a23
4490       a_temp(2,1)=a32
4491       a_temp(2,2)=a33
4492 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4493 !
4494 !               Third-order contributions
4495 !
4496 !                 (i+2)o----(i+3)
4497 !                      | |
4498 !                      | |
4499 !                 (i+1)o----i
4500 !
4501 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4502 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4503         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4504         call transpose2(auxmat(1,1),auxmat1(1,1))
4505         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4506         if (shield_mode.eq.0) then
4507         fac_shield(i)=1.0d0
4508         fac_shield(j)=1.0d0
4509         endif
4510
4511         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4512          *fac_shield(i)*fac_shield(j)  &
4513          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4514         eello_t3= &
4515         0.5d0*(pizda(1,1)+pizda(2,2)) &
4516         *fac_shield(i)*fac_shield(j)
4517
4518         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4519                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4520           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4521        (shield_mode.gt.0)) then
4522 !C          print *,i,j
4523
4524           do ilist=1,ishield_list(i)
4525            iresshield=shield_list(ilist,i)
4526            do k=1,3
4527            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4528            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4529                    rlocshield &
4530            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4531             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4532              +rlocshield
4533            enddo
4534           enddo
4535           do ilist=1,ishield_list(j)
4536            iresshield=shield_list(ilist,j)
4537            do k=1,3
4538            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4539            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4540                    rlocshield &
4541            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4542            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4543                   +rlocshield
4544
4545            enddo
4546           enddo
4547
4548           do k=1,3
4549             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4550                    grad_shield(k,i)*eello_t3/fac_shield(i)
4551             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4552                    grad_shield(k,j)*eello_t3/fac_shield(j)
4553             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4554                    grad_shield(k,i)*eello_t3/fac_shield(i)
4555             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4556                    grad_shield(k,j)*eello_t3/fac_shield(j)
4557            enddo
4558            endif
4559
4560 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4561 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4562 !d     &    ' eello_turn3_num',4*eello_turn3_num
4563 ! Derivatives in gamma(i)
4564         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4565         call transpose2(auxmat2(1,1),auxmat3(1,1))
4566         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4567         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4568           *fac_shield(i)*fac_shield(j)        &
4569           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4570 ! Derivatives in gamma(i+1)
4571         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4572         call transpose2(auxmat2(1,1),auxmat3(1,1))
4573         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4574         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4575           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4576           *fac_shield(i)*fac_shield(j)        &
4577           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4578
4579 ! Cartesian derivatives
4580         do l=1,3
4581 !            ghalf1=0.5d0*agg(l,1)
4582 !            ghalf2=0.5d0*agg(l,2)
4583 !            ghalf3=0.5d0*agg(l,3)
4584 !            ghalf4=0.5d0*agg(l,4)
4585           a_temp(1,1)=aggi(l,1)!+ghalf1
4586           a_temp(1,2)=aggi(l,2)!+ghalf2
4587           a_temp(2,1)=aggi(l,3)!+ghalf3
4588           a_temp(2,2)=aggi(l,4)!+ghalf4
4589           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4590           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4591             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4592           *fac_shield(i)*fac_shield(j)      &
4593           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4594
4595           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4596           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4597           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4598           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4599           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4600           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4601             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4602           *fac_shield(i)*fac_shield(j)        &
4603           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4604
4605           a_temp(1,1)=aggj(l,1)!+ghalf1
4606           a_temp(1,2)=aggj(l,2)!+ghalf2
4607           a_temp(2,1)=aggj(l,3)!+ghalf3
4608           a_temp(2,2)=aggj(l,4)!+ghalf4
4609           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4610           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4611             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4612           *fac_shield(i)*fac_shield(j)      &
4613           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4614
4615           a_temp(1,1)=aggj1(l,1)
4616           a_temp(1,2)=aggj1(l,2)
4617           a_temp(2,1)=aggj1(l,3)
4618           a_temp(2,2)=aggj1(l,4)
4619           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4620           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4621             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4622           *fac_shield(i)*fac_shield(j)        &
4623           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4624         enddo
4625          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4626           ssgradlipi*eello_t3/4.0d0*lipscale
4627          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4628           ssgradlipj*eello_t3/4.0d0*lipscale
4629          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4630           ssgradlipi*eello_t3/4.0d0*lipscale
4631          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4632           ssgradlipj*eello_t3/4.0d0*lipscale
4633
4634       return
4635       end subroutine eturn3
4636 !-----------------------------------------------------------------------------
4637       subroutine eturn4(i,eello_turn4)
4638 ! Third- and fourth-order contributions from turns
4639
4640       use comm_locel
4641 !      implicit real*8 (a-h,o-z)
4642 !      include 'DIMENSIONS'
4643 !      include 'COMMON.IOUNITS'
4644 !      include 'COMMON.GEO'
4645 !      include 'COMMON.VAR'
4646 !      include 'COMMON.LOCAL'
4647 !      include 'COMMON.CHAIN'
4648 !      include 'COMMON.DERIV'
4649 !      include 'COMMON.INTERACT'
4650 !      include 'COMMON.CONTACTS'
4651 !      include 'COMMON.TORSION'
4652 !      include 'COMMON.VECTORS'
4653 !      include 'COMMON.FFIELD'
4654 !      include 'COMMON.CONTROL'
4655       real(kind=8),dimension(3) :: ggg
4656       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4657         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4658       real(kind=8),dimension(2) :: auxvec,auxvec1
4659 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4660       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4661 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4662 !el        dz_normi,xmedi,ymedi,zmedi
4663 !el      integer :: num_conti,j1,j2
4664 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4665 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4666 !el          num_conti,j1,j2
4667 !el local variables
4668       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4669       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4670          rlocshield
4671
4672       j=i+3
4673 !      if (j.ne.20) return
4674 !      print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1)
4675 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4676 !
4677 !               Fourth-order contributions
4678 !
4679 !                 (i+3)o----(i+4)
4680 !                     /  |
4681 !               (i+2)o   |
4682 !                     \  |
4683 !                 (i+1)o----i
4684 !
4685 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4686 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4687 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4688           zj=(c(3,j)+c(3,j+1))/2.0d0
4689           zj=mod(zj,boxzsize)
4690           if (zj.lt.0) zj=zj+boxzsize
4691        if ((zj.gt.bordlipbot)  &
4692         .and.(zj.lt.bordliptop)) then
4693 !C the energy transfer exist
4694         if (zj.lt.buflipbot) then
4695 !C what fraction I am in
4696          fracinbuf=1.0d0-     &
4697              ((zj-bordlipbot)/lipbufthick)
4698 !C lipbufthick is thickenes of lipid buffore
4699          sslipj=sscalelip(fracinbuf)
4700          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4701         elseif (zj.gt.bufliptop) then
4702          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4703          sslipj=sscalelip(fracinbuf)
4704          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4705         else
4706          sslipj=1.0d0
4707          ssgradlipj=0.0
4708         endif
4709        else
4710          sslipj=0.0d0
4711          ssgradlipj=0.0
4712        endif
4713
4714         a_temp(1,1)=a22
4715         a_temp(1,2)=a23
4716         a_temp(2,1)=a32
4717         a_temp(2,2)=a33
4718         iti1=itortyp(itype(i+1,1))
4719         iti2=itortyp(itype(i+2,1))
4720         iti3=itortyp(itype(i+3,1))
4721 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4722         call transpose2(EUg(1,1,i+1),e1t(1,1))
4723         call transpose2(Eug(1,1,i+2),e2t(1,1))
4724         call transpose2(Eug(1,1,i+3),e3t(1,1))
4725         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4726         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4727         s1=scalar2(b1(1,iti2),auxvec(1))
4728         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4729         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4730         s2=scalar2(b1(1,iti1),auxvec(1))
4731         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4732         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4733         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4734         if (shield_mode.eq.0) then
4735         fac_shield(i)=1.0
4736         fac_shield(j)=1.0
4737         endif
4738
4739         eello_turn4=eello_turn4-(s1+s2+s3) &
4740         *fac_shield(i)*fac_shield(j)       &
4741         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4742         eello_t4=-(s1+s2+s3)  &
4743           *fac_shield(i)*fac_shield(j)
4744 !C Now derivative over shield:
4745           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4746          (shield_mode.gt.0)) then
4747 !C          print *,i,j
4748
4749           do ilist=1,ishield_list(i)
4750            iresshield=shield_list(ilist,i)
4751            do k=1,3
4752            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4753 !           print *,"rlocshield",rlocshield,grad_shield_side(k,ilist,i),iresshield
4754            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4755                    rlocshield &
4756             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4757             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4758            +rlocshield
4759            enddo
4760           enddo
4761           do ilist=1,ishield_list(j)
4762            iresshield=shield_list(ilist,j)
4763            do k=1,3
4764 !           print *,"rlocshieldj",j,rlocshield,grad_shield_side(k,ilist,j),iresshield
4765            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4766            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4767                    rlocshield  &
4768            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4769            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4770                   +rlocshield
4771 !            print *,"after", gshieldc_t4(k,iresshield-1),iresshield-1,gshieldc_t4(k,iresshield)
4772
4773            enddo
4774           enddo
4775           do k=1,3
4776             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
4777                    grad_shield(k,i)*eello_t4/fac_shield(i)
4778             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
4779                    grad_shield(k,j)*eello_t4/fac_shield(j)
4780             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
4781                    grad_shield(k,i)*eello_t4/fac_shield(i)
4782             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
4783                    grad_shield(k,j)*eello_t4/fac_shield(j)
4784 !           print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1)
4785            enddo
4786            endif
4787
4788         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4789            'eturn4',i,j,-(s1+s2+s3)
4790 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4791 !d     &    ' eello_turn4_num',8*eello_turn4_num
4792 ! Derivatives in gamma(i)
4793         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4794         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4795         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4796         s1=scalar2(b1(1,iti2),auxvec(1))
4797         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4798         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4799         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
4800        *fac_shield(i)*fac_shield(j)  &
4801        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4802
4803 ! Derivatives in gamma(i+1)
4804         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4805         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4806         s2=scalar2(b1(1,iti1),auxvec(1))
4807         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4808         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4809         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4810         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
4811        *fac_shield(i)*fac_shield(j)  &
4812        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4813
4814 ! Derivatives in gamma(i+2)
4815         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4816         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4817         s1=scalar2(b1(1,iti2),auxvec(1))
4818         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4819         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4820         s2=scalar2(b1(1,iti1),auxvec(1))
4821         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4822         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4823         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4824         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
4825        *fac_shield(i)*fac_shield(j)  &
4826        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4827
4828 ! Cartesian derivatives
4829 ! Derivatives of this turn contributions in DC(i+2)
4830         if (j.lt.nres-1) then
4831           do l=1,3
4832             a_temp(1,1)=agg(l,1)
4833             a_temp(1,2)=agg(l,2)
4834             a_temp(2,1)=agg(l,3)
4835             a_temp(2,2)=agg(l,4)
4836             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4837             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4838             s1=scalar2(b1(1,iti2),auxvec(1))
4839             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4840             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4841             s2=scalar2(b1(1,iti1),auxvec(1))
4842             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4843             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4844             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4845             ggg(l)=-(s1+s2+s3)
4846             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
4847        *fac_shield(i)*fac_shield(j)  &
4848        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4849
4850           enddo
4851         endif
4852 ! Remaining derivatives of this turn contribution
4853         do l=1,3
4854           a_temp(1,1)=aggi(l,1)
4855           a_temp(1,2)=aggi(l,2)
4856           a_temp(2,1)=aggi(l,3)
4857           a_temp(2,2)=aggi(l,4)
4858           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4859           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4860           s1=scalar2(b1(1,iti2),auxvec(1))
4861           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4862           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4863           s2=scalar2(b1(1,iti1),auxvec(1))
4864           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4865           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4866           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4867           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
4868          *fac_shield(i)*fac_shield(j)  &
4869          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4870
4871
4872           a_temp(1,1)=aggi1(l,1)
4873           a_temp(1,2)=aggi1(l,2)
4874           a_temp(2,1)=aggi1(l,3)
4875           a_temp(2,2)=aggi1(l,4)
4876           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4877           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4878           s1=scalar2(b1(1,iti2),auxvec(1))
4879           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4880           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4881           s2=scalar2(b1(1,iti1),auxvec(1))
4882           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4883           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4884           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4885           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
4886          *fac_shield(i)*fac_shield(j)  &
4887          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4888
4889
4890           a_temp(1,1)=aggj(l,1)
4891           a_temp(1,2)=aggj(l,2)
4892           a_temp(2,1)=aggj(l,3)
4893           a_temp(2,2)=aggj(l,4)
4894           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4895           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4896           s1=scalar2(b1(1,iti2),auxvec(1))
4897           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4898           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4899           s2=scalar2(b1(1,iti1),auxvec(1))
4900           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4901           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4902           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4903 !        if (j.lt.nres-1) then
4904           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
4905          *fac_shield(i)*fac_shield(j)  &
4906          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4907 !        endif
4908
4909           a_temp(1,1)=aggj1(l,1)
4910           a_temp(1,2)=aggj1(l,2)
4911           a_temp(2,1)=aggj1(l,3)
4912           a_temp(2,2)=aggj1(l,4)
4913           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4914           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4915           s1=scalar2(b1(1,iti2),auxvec(1))
4916           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4917           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4918           s2=scalar2(b1(1,iti1),auxvec(1))
4919           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4920           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4921           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4922 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4923 !        if (j.lt.nres-1) then
4924 !          print *,"juest before",j1, gcorr4_turn(l,j1)
4925           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
4926          *fac_shield(i)*fac_shield(j)  &
4927          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4928 !            if (shield_mode.gt.0) then
4929 !             print *,"juest after",j1, gcorr4_turn(l,j1),gshieldc_t4(k,j1),gshieldc_loc_t4(k,j1),gel_loc_turn4(i+2)
4930 !            else
4931 !             print *,"juest after",j1, gcorr4_turn(l,j1),gel_loc_turn4(i+2)
4932 !            endif
4933 !         endif
4934         enddo
4935          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
4936           ssgradlipi*eello_t4/4.0d0*lipscale
4937          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
4938           ssgradlipj*eello_t4/4.0d0*lipscale
4939          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
4940           ssgradlipi*eello_t4/4.0d0*lipscale
4941          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
4942           ssgradlipj*eello_t4/4.0d0*lipscale
4943
4944       return
4945       end subroutine eturn4
4946 !-----------------------------------------------------------------------------
4947       subroutine unormderiv(u,ugrad,unorm,ungrad)
4948 ! This subroutine computes the derivatives of a normalized vector u, given
4949 ! the derivatives computed without normalization conditions, ugrad. Returns
4950 ! ungrad.
4951 !      implicit none
4952       real(kind=8),dimension(3) :: u,vec
4953       real(kind=8),dimension(3,3) ::ugrad,ungrad
4954       real(kind=8) :: unorm      !,scalar
4955       integer :: i,j
4956 !      write (2,*) 'ugrad',ugrad
4957 !      write (2,*) 'u',u
4958       do i=1,3
4959         vec(i)=scalar(ugrad(1,i),u(1))
4960       enddo
4961 !      write (2,*) 'vec',vec
4962       do i=1,3
4963         do j=1,3
4964           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4965         enddo
4966       enddo
4967 !      write (2,*) 'ungrad',ungrad
4968       return
4969       end subroutine unormderiv
4970 !-----------------------------------------------------------------------------
4971       subroutine escp_soft_sphere(evdw2,evdw2_14)
4972 !
4973 ! This subroutine calculates the excluded-volume interaction energy between
4974 ! peptide-group centers and side chains and its gradient in virtual-bond and
4975 ! side-chain vectors.
4976 !
4977 !      implicit real*8 (a-h,o-z)
4978 !      include 'DIMENSIONS'
4979 !      include 'COMMON.GEO'
4980 !      include 'COMMON.VAR'
4981 !      include 'COMMON.LOCAL'
4982 !      include 'COMMON.CHAIN'
4983 !      include 'COMMON.DERIV'
4984 !      include 'COMMON.INTERACT'
4985 !      include 'COMMON.FFIELD'
4986 !      include 'COMMON.IOUNITS'
4987 !      include 'COMMON.CONTROL'
4988       real(kind=8),dimension(3) :: ggg
4989 !el local variables
4990       integer :: i,iint,j,k,iteli,itypj
4991       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
4992                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
4993
4994       evdw2=0.0D0
4995       evdw2_14=0.0d0
4996       r0_scp=4.5d0
4997 !d    print '(a)','Enter ESCP'
4998 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4999       do i=iatscp_s,iatscp_e
5000         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5001         iteli=itel(i)
5002         xi=0.5D0*(c(1,i)+c(1,i+1))
5003         yi=0.5D0*(c(2,i)+c(2,i+1))
5004         zi=0.5D0*(c(3,i)+c(3,i+1))
5005
5006         do iint=1,nscp_gr(i)
5007
5008         do j=iscpstart(i,iint),iscpend(i,iint)
5009           if (itype(j,1).eq.ntyp1) cycle
5010           itypj=iabs(itype(j,1))
5011 ! Uncomment following three lines for SC-p interactions
5012 !         xj=c(1,nres+j)-xi
5013 !         yj=c(2,nres+j)-yi
5014 !         zj=c(3,nres+j)-zi
5015 ! Uncomment following three lines for Ca-p interactions
5016           xj=c(1,j)-xi
5017           yj=c(2,j)-yi
5018           zj=c(3,j)-zi
5019           rij=xj*xj+yj*yj+zj*zj
5020           r0ij=r0_scp
5021           r0ijsq=r0ij*r0ij
5022           if (rij.lt.r0ijsq) then
5023             evdwij=0.25d0*(rij-r0ijsq)**2
5024             fac=rij-r0ijsq
5025           else
5026             evdwij=0.0d0
5027             fac=0.0d0
5028           endif
5029           evdw2=evdw2+evdwij
5030 !
5031 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5032 !
5033           ggg(1)=xj*fac
5034           ggg(2)=yj*fac
5035           ggg(3)=zj*fac
5036 !grad          if (j.lt.i) then
5037 !d          write (iout,*) 'j<i'
5038 ! Uncomment following three lines for SC-p interactions
5039 !           do k=1,3
5040 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5041 !           enddo
5042 !grad          else
5043 !d          write (iout,*) 'j>i'
5044 !grad            do k=1,3
5045 !grad              ggg(k)=-ggg(k)
5046 ! Uncomment following line for SC-p interactions
5047 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5048 !grad            enddo
5049 !grad          endif
5050 !grad          do k=1,3
5051 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5052 !grad          enddo
5053 !grad          kstart=min0(i+1,j)
5054 !grad          kend=max0(i-1,j-1)
5055 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5056 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5057 !grad          do k=kstart,kend
5058 !grad            do l=1,3
5059 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5060 !grad            enddo
5061 !grad          enddo
5062           do k=1,3
5063             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5064             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5065           enddo
5066         enddo
5067
5068         enddo ! iint
5069       enddo ! i
5070       return
5071       end subroutine escp_soft_sphere
5072 !-----------------------------------------------------------------------------
5073       subroutine escp(evdw2,evdw2_14)
5074 !
5075 ! This subroutine calculates the excluded-volume interaction energy between
5076 ! peptide-group centers and side chains and its gradient in virtual-bond and
5077 ! side-chain vectors.
5078 !
5079 !      implicit real*8 (a-h,o-z)
5080 !      include 'DIMENSIONS'
5081 !      include 'COMMON.GEO'
5082 !      include 'COMMON.VAR'
5083 !      include 'COMMON.LOCAL'
5084 !      include 'COMMON.CHAIN'
5085 !      include 'COMMON.DERIV'
5086 !      include 'COMMON.INTERACT'
5087 !      include 'COMMON.FFIELD'
5088 !      include 'COMMON.IOUNITS'
5089 !      include 'COMMON.CONTROL'
5090       real(kind=8),dimension(3) :: ggg
5091 !el local variables
5092       integer :: i,iint,j,k,iteli,itypj,subchap
5093       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
5094                    e1,e2,evdwij,rij
5095       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
5096                     dist_temp, dist_init
5097       integer xshift,yshift,zshift
5098
5099       evdw2=0.0D0
5100       evdw2_14=0.0d0
5101 !d    print '(a)','Enter ESCP'
5102 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5103       do i=iatscp_s,iatscp_e
5104         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5105         iteli=itel(i)
5106         xi=0.5D0*(c(1,i)+c(1,i+1))
5107         yi=0.5D0*(c(2,i)+c(2,i+1))
5108         zi=0.5D0*(c(3,i)+c(3,i+1))
5109           xi=mod(xi,boxxsize)
5110           if (xi.lt.0) xi=xi+boxxsize
5111           yi=mod(yi,boxysize)
5112           if (yi.lt.0) yi=yi+boxysize
5113           zi=mod(zi,boxzsize)
5114           if (zi.lt.0) zi=zi+boxzsize
5115
5116         do iint=1,nscp_gr(i)
5117
5118         do j=iscpstart(i,iint),iscpend(i,iint)
5119           itypj=iabs(itype(j,1))
5120           if (itypj.eq.ntyp1) cycle
5121 ! Uncomment following three lines for SC-p interactions
5122 !         xj=c(1,nres+j)-xi
5123 !         yj=c(2,nres+j)-yi
5124 !         zj=c(3,nres+j)-zi
5125 ! Uncomment following three lines for Ca-p interactions
5126 !          xj=c(1,j)-xi
5127 !          yj=c(2,j)-yi
5128 !          zj=c(3,j)-zi
5129           xj=c(1,j)
5130           yj=c(2,j)
5131           zj=c(3,j)
5132           xj=mod(xj,boxxsize)
5133           if (xj.lt.0) xj=xj+boxxsize
5134           yj=mod(yj,boxysize)
5135           if (yj.lt.0) yj=yj+boxysize
5136           zj=mod(zj,boxzsize)
5137           if (zj.lt.0) zj=zj+boxzsize
5138       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5139       xj_safe=xj
5140       yj_safe=yj
5141       zj_safe=zj
5142       subchap=0
5143       do xshift=-1,1
5144       do yshift=-1,1
5145       do zshift=-1,1
5146           xj=xj_safe+xshift*boxxsize
5147           yj=yj_safe+yshift*boxysize
5148           zj=zj_safe+zshift*boxzsize
5149           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5150           if(dist_temp.lt.dist_init) then
5151             dist_init=dist_temp
5152             xj_temp=xj
5153             yj_temp=yj
5154             zj_temp=zj
5155             subchap=1
5156           endif
5157        enddo
5158        enddo
5159        enddo
5160        if (subchap.eq.1) then
5161           xj=xj_temp-xi
5162           yj=yj_temp-yi
5163           zj=zj_temp-zi
5164        else
5165           xj=xj_safe-xi
5166           yj=yj_safe-yi
5167           zj=zj_safe-zi
5168        endif
5169
5170           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5171           rij=dsqrt(1.0d0/rrij)
5172             sss_ele_cut=sscale_ele(rij)
5173             sss_ele_grad=sscagrad_ele(rij)
5174 !            print *,sss_ele_cut,sss_ele_grad,&
5175 !            (rij),r_cut_ele,rlamb_ele
5176             if (sss_ele_cut.le.0.0) cycle
5177           fac=rrij**expon2
5178           e1=fac*fac*aad(itypj,iteli)
5179           e2=fac*bad(itypj,iteli)
5180           if (iabs(j-i) .le. 2) then
5181             e1=scal14*e1
5182             e2=scal14*e2
5183             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5184           endif
5185           evdwij=e1+e2
5186           evdw2=evdw2+evdwij*sss_ele_cut
5187 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5188 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5189           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5190              'evdw2',i,j,evdwij
5191 !
5192 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5193 !
5194           fac=-(evdwij+e1)*rrij*sss_ele_cut
5195           fac=fac+evdwij*sss_ele_grad/rij/expon
5196           ggg(1)=xj*fac
5197           ggg(2)=yj*fac
5198           ggg(3)=zj*fac
5199 !grad          if (j.lt.i) then
5200 !d          write (iout,*) 'j<i'
5201 ! Uncomment following three lines for SC-p interactions
5202 !           do k=1,3
5203 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5204 !           enddo
5205 !grad          else
5206 !d          write (iout,*) 'j>i'
5207 !grad            do k=1,3
5208 !grad              ggg(k)=-ggg(k)
5209 ! Uncomment following line for SC-p interactions
5210 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5211 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5212 !grad            enddo
5213 !grad          endif
5214 !grad          do k=1,3
5215 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5216 !grad          enddo
5217 !grad          kstart=min0(i+1,j)
5218 !grad          kend=max0(i-1,j-1)
5219 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5220 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5221 !grad          do k=kstart,kend
5222 !grad            do l=1,3
5223 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5224 !grad            enddo
5225 !grad          enddo
5226           do k=1,3
5227             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5228             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5229           enddo
5230         enddo
5231
5232         enddo ! iint
5233       enddo ! i
5234       do i=1,nct
5235         do j=1,3
5236           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5237           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5238           gradx_scp(j,i)=expon*gradx_scp(j,i)
5239         enddo
5240       enddo
5241 !******************************************************************************
5242 !
5243 !                              N O T E !!!
5244 !
5245 ! To save time the factor EXPON has been extracted from ALL components
5246 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5247 ! use!
5248 !
5249 !******************************************************************************
5250       return
5251       end subroutine escp
5252 !-----------------------------------------------------------------------------
5253       subroutine edis(ehpb)
5254 !
5255 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5256 !
5257 !      implicit real*8 (a-h,o-z)
5258 !      include 'DIMENSIONS'
5259 !      include 'COMMON.SBRIDGE'
5260 !      include 'COMMON.CHAIN'
5261 !      include 'COMMON.DERIV'
5262 !      include 'COMMON.VAR'
5263 !      include 'COMMON.INTERACT'
5264 !      include 'COMMON.IOUNITS'
5265       real(kind=8),dimension(3) :: ggg
5266 !el local variables
5267       integer :: i,j,ii,jj,iii,jjj,k
5268       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5269
5270       ehpb=0.0D0
5271 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5272 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5273       if (link_end.eq.0) return
5274       do i=link_start,link_end
5275 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5276 ! CA-CA distance used in regularization of structure.
5277         ii=ihpb(i)
5278         jj=jhpb(i)
5279 ! iii and jjj point to the residues for which the distance is assigned.
5280         if (ii.gt.nres) then
5281           iii=ii-nres
5282           jjj=jj-nres
5283         else
5284           iii=ii
5285           jjj=jj
5286         endif
5287 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5288 !     &    dhpb(i),dhpb1(i),forcon(i)
5289 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5290 !    distance and angle dependent SS bond potential.
5291 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5292 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5293         if (.not.dyn_ss .and. i.le.nss) then
5294 ! 15/02/13 CC dynamic SSbond - additional check
5295          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5296         iabs(itype(jjj,1)).eq.1) then
5297           call ssbond_ene(iii,jjj,eij)
5298           ehpb=ehpb+2*eij
5299 !d          write (iout,*) "eij",eij
5300          endif
5301         else if (ii.gt.nres .and. jj.gt.nres) then
5302 !c Restraints from contact prediction
5303           dd=dist(ii,jj)
5304           if (constr_dist.eq.11) then
5305             ehpb=ehpb+fordepth(i)**4.0d0 &
5306                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5307             fac=fordepth(i)**4.0d0 &
5308                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5309           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5310             ehpb,fordepth(i),dd
5311            else
5312           if (dhpb1(i).gt.0.0d0) then
5313             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5314             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5315 !c            write (iout,*) "beta nmr",
5316 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5317           else
5318             dd=dist(ii,jj)
5319             rdis=dd-dhpb(i)
5320 !C Get the force constant corresponding to this distance.
5321             waga=forcon(i)
5322 !C Calculate the contribution to energy.
5323             ehpb=ehpb+waga*rdis*rdis
5324 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5325 !C
5326 !C Evaluate gradient.
5327 !C
5328             fac=waga*rdis/dd
5329           endif
5330           endif
5331           do j=1,3
5332             ggg(j)=fac*(c(j,jj)-c(j,ii))
5333           enddo
5334           do j=1,3
5335             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5336             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5337           enddo
5338           do k=1,3
5339             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5340             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5341           enddo
5342         else
5343           dd=dist(ii,jj)
5344           if (constr_dist.eq.11) then
5345             ehpb=ehpb+fordepth(i)**4.0d0 &
5346                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5347             fac=fordepth(i)**4.0d0 &
5348                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5349           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5350          ehpb,fordepth(i),dd
5351            else
5352           if (dhpb1(i).gt.0.0d0) then
5353             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5354             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5355 !c            write (iout,*) "alph nmr",
5356 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5357           else
5358             rdis=dd-dhpb(i)
5359 !C Get the force constant corresponding to this distance.
5360             waga=forcon(i)
5361 !C Calculate the contribution to energy.
5362             ehpb=ehpb+waga*rdis*rdis
5363 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5364 !C
5365 !C Evaluate gradient.
5366 !C
5367             fac=waga*rdis/dd
5368           endif
5369           endif
5370
5371             do j=1,3
5372               ggg(j)=fac*(c(j,jj)-c(j,ii))
5373             enddo
5374 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5375 !C If this is a SC-SC distance, we need to calculate the contributions to the
5376 !C Cartesian gradient in the SC vectors (ghpbx).
5377           if (iii.lt.ii) then
5378           do j=1,3
5379             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5380             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5381           enddo
5382           endif
5383 !cgrad        do j=iii,jjj-1
5384 !cgrad          do k=1,3
5385 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5386 !cgrad          enddo
5387 !cgrad        enddo
5388           do k=1,3
5389             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5390             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5391           enddo
5392         endif
5393       enddo
5394       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5395
5396       return
5397       end subroutine edis
5398 !-----------------------------------------------------------------------------
5399       subroutine ssbond_ene(i,j,eij)
5400 !
5401 ! Calculate the distance and angle dependent SS-bond potential energy
5402 ! using a free-energy function derived based on RHF/6-31G** ab initio
5403 ! calculations of diethyl disulfide.
5404 !
5405 ! A. Liwo and U. Kozlowska, 11/24/03
5406 !
5407 !      implicit real*8 (a-h,o-z)
5408 !      include 'DIMENSIONS'
5409 !      include 'COMMON.SBRIDGE'
5410 !      include 'COMMON.CHAIN'
5411 !      include 'COMMON.DERIV'
5412 !      include 'COMMON.LOCAL'
5413 !      include 'COMMON.INTERACT'
5414 !      include 'COMMON.VAR'
5415 !      include 'COMMON.IOUNITS'
5416       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5417 !el local variables
5418       integer :: i,j,itypi,itypj,k
5419       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5420                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5421                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5422                    cosphi,ggk
5423
5424       itypi=iabs(itype(i,1))
5425       xi=c(1,nres+i)
5426       yi=c(2,nres+i)
5427       zi=c(3,nres+i)
5428       dxi=dc_norm(1,nres+i)
5429       dyi=dc_norm(2,nres+i)
5430       dzi=dc_norm(3,nres+i)
5431 !      dsci_inv=dsc_inv(itypi)
5432       dsci_inv=vbld_inv(nres+i)
5433       itypj=iabs(itype(j,1))
5434 !      dscj_inv=dsc_inv(itypj)
5435       dscj_inv=vbld_inv(nres+j)
5436       xj=c(1,nres+j)-xi
5437       yj=c(2,nres+j)-yi
5438       zj=c(3,nres+j)-zi
5439       dxj=dc_norm(1,nres+j)
5440       dyj=dc_norm(2,nres+j)
5441       dzj=dc_norm(3,nres+j)
5442       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5443       rij=dsqrt(rrij)
5444       erij(1)=xj*rij
5445       erij(2)=yj*rij
5446       erij(3)=zj*rij
5447       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5448       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5449       om12=dxi*dxj+dyi*dyj+dzi*dzj
5450       do k=1,3
5451         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5452         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5453       enddo
5454       rij=1.0d0/rij
5455       deltad=rij-d0cm
5456       deltat1=1.0d0-om1
5457       deltat2=1.0d0+om2
5458       deltat12=om2-om1+2.0d0
5459       cosphi=om12-om1*om2
5460       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5461         +akct*deltad*deltat12 &
5462         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5463 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5464 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5465 !     &  " deltat12",deltat12," eij",eij
5466       ed=2*akcm*deltad+akct*deltat12
5467       pom1=akct*deltad
5468       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5469       eom1=-2*akth*deltat1-pom1-om2*pom2
5470       eom2= 2*akth*deltat2+pom1-om1*pom2
5471       eom12=pom2
5472       do k=1,3
5473         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5474         ghpbx(k,i)=ghpbx(k,i)-ggk &
5475                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5476                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5477         ghpbx(k,j)=ghpbx(k,j)+ggk &
5478                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5479                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5480         ghpbc(k,i)=ghpbc(k,i)-ggk
5481         ghpbc(k,j)=ghpbc(k,j)+ggk
5482       enddo
5483 !
5484 ! Calculate the components of the gradient in DC and X
5485 !
5486 !grad      do k=i,j-1
5487 !grad        do l=1,3
5488 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5489 !grad        enddo
5490 !grad      enddo
5491       return
5492       end subroutine ssbond_ene
5493 !-----------------------------------------------------------------------------
5494       subroutine ebond(estr)
5495 !
5496 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5497 !
5498 !      implicit real*8 (a-h,o-z)
5499 !      include 'DIMENSIONS'
5500 !      include 'COMMON.LOCAL'
5501 !      include 'COMMON.GEO'
5502 !      include 'COMMON.INTERACT'
5503 !      include 'COMMON.DERIV'
5504 !      include 'COMMON.VAR'
5505 !      include 'COMMON.CHAIN'
5506 !      include 'COMMON.IOUNITS'
5507 !      include 'COMMON.NAMES'
5508 !      include 'COMMON.FFIELD'
5509 !      include 'COMMON.CONTROL'
5510 !      include 'COMMON.SETUP'
5511       real(kind=8),dimension(3) :: u,ud
5512 !el local variables
5513       integer :: i,j,iti,nbi,k
5514       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5515                    uprod1,uprod2
5516
5517       estr=0.0d0
5518       estr1=0.0d0
5519 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5520 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5521
5522       do i=ibondp_start,ibondp_end
5523         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5524         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5525 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5526 !C          do j=1,3
5527 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5528 !C            *dc(j,i-1)/vbld(i)
5529 !C          enddo
5530 !C          if (energy_dec) write(iout,*) &
5531 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5532         diff = vbld(i)-vbldpDUM
5533         else
5534         diff = vbld(i)-vbldp0
5535         endif
5536         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5537            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5538         estr=estr+diff*diff
5539         do j=1,3
5540           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5541         enddo
5542 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5543 !        endif
5544       enddo
5545       estr=0.5d0*AKP*estr+estr1
5546 !      print *,"estr_bb",estr,AKP
5547 !
5548 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5549 !
5550       do i=ibond_start,ibond_end
5551         iti=iabs(itype(i,1))
5552         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5553         if (iti.ne.10 .and. iti.ne.ntyp1) then
5554           nbi=nbondterm(iti)
5555           if (nbi.eq.1) then
5556             diff=vbld(i+nres)-vbldsc0(1,iti)
5557             if (energy_dec) write (iout,*) &
5558             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5559             AKSC(1,iti),AKSC(1,iti)*diff*diff
5560             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5561 !            print *,"estr_sc",estr
5562             do j=1,3
5563               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5564             enddo
5565           else
5566             do j=1,nbi
5567               diff=vbld(i+nres)-vbldsc0(j,iti)
5568               ud(j)=aksc(j,iti)*diff
5569               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5570             enddo
5571             uprod=u(1)
5572             do j=2,nbi
5573               uprod=uprod*u(j)
5574             enddo
5575             usum=0.0d0
5576             usumsqder=0.0d0
5577             do j=1,nbi
5578               uprod1=1.0d0
5579               uprod2=1.0d0
5580               do k=1,nbi
5581                 if (k.ne.j) then
5582                   uprod1=uprod1*u(k)
5583                   uprod2=uprod2*u(k)*u(k)
5584                 endif
5585               enddo
5586               usum=usum+uprod1
5587               usumsqder=usumsqder+ud(j)*uprod2
5588             enddo
5589             estr=estr+uprod/usum
5590 !            print *,"estr_sc",estr,i
5591
5592              if (energy_dec) write (iout,*) &
5593             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5594             AKSC(1,iti),uprod/usum
5595             do j=1,3
5596              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5597             enddo
5598           endif
5599         endif
5600       enddo
5601       return
5602       end subroutine ebond
5603 #ifdef CRYST_THETA
5604 !-----------------------------------------------------------------------------
5605       subroutine ebend(etheta)
5606 !
5607 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5608 ! angles gamma and its derivatives in consecutive thetas and gammas.
5609 !
5610       use comm_calcthet
5611 !      implicit real*8 (a-h,o-z)
5612 !      include 'DIMENSIONS'
5613 !      include 'COMMON.LOCAL'
5614 !      include 'COMMON.GEO'
5615 !      include 'COMMON.INTERACT'
5616 !      include 'COMMON.DERIV'
5617 !      include 'COMMON.VAR'
5618 !      include 'COMMON.CHAIN'
5619 !      include 'COMMON.IOUNITS'
5620 !      include 'COMMON.NAMES'
5621 !      include 'COMMON.FFIELD'
5622 !      include 'COMMON.CONTROL'
5623 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5624 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5625 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5626 !el      integer :: it
5627 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5628 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5629 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5630 !el local variables
5631       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5632        ichir21,ichir22
5633       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5634        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5635        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5636       real(kind=8),dimension(2) :: y,z
5637
5638       delta=0.02d0*pi
5639 !      time11=dexp(-2*time)
5640 !      time12=1.0d0
5641       etheta=0.0D0
5642 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5643       do i=ithet_start,ithet_end
5644         if (itype(i-1,1).eq.ntyp1) cycle
5645 ! Zero the energy function and its derivative at 0 or pi.
5646         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5647         it=itype(i-1,1)
5648         ichir1=isign(1,itype(i-2,1))
5649         ichir2=isign(1,itype(i,1))
5650          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5651          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5652          if (itype(i-1,1).eq.10) then
5653           itype1=isign(10,itype(i-2,1))
5654           ichir11=isign(1,itype(i-2,1))
5655           ichir12=isign(1,itype(i-2,1))
5656           itype2=isign(10,itype(i,1))
5657           ichir21=isign(1,itype(i,1))
5658           ichir22=isign(1,itype(i,1))
5659          endif
5660
5661         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5662 #ifdef OSF
5663           phii=phi(i)
5664           if (phii.ne.phii) phii=150.0
5665 #else
5666           phii=phi(i)
5667 #endif
5668           y(1)=dcos(phii)
5669           y(2)=dsin(phii)
5670         else
5671           y(1)=0.0D0
5672           y(2)=0.0D0
5673         endif
5674         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5675 #ifdef OSF
5676           phii1=phi(i+1)
5677           if (phii1.ne.phii1) phii1=150.0
5678           phii1=pinorm(phii1)
5679           z(1)=cos(phii1)
5680 #else
5681           phii1=phi(i+1)
5682           z(1)=dcos(phii1)
5683 #endif
5684           z(2)=dsin(phii1)
5685         else
5686           z(1)=0.0D0
5687           z(2)=0.0D0
5688         endif
5689 ! Calculate the "mean" value of theta from the part of the distribution
5690 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5691 ! In following comments this theta will be referred to as t_c.
5692         thet_pred_mean=0.0d0
5693         do k=1,2
5694             athetk=athet(k,it,ichir1,ichir2)
5695             bthetk=bthet(k,it,ichir1,ichir2)
5696           if (it.eq.10) then
5697              athetk=athet(k,itype1,ichir11,ichir12)
5698              bthetk=bthet(k,itype2,ichir21,ichir22)
5699           endif
5700          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5701         enddo
5702         dthett=thet_pred_mean*ssd
5703         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5704 ! Derivatives of the "mean" values in gamma1 and gamma2.
5705         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5706                +athet(2,it,ichir1,ichir2)*y(1))*ss
5707         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5708                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5709          if (it.eq.10) then
5710         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5711              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5712         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5713                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5714          endif
5715         if (theta(i).gt.pi-delta) then
5716           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5717                E_tc0)
5718           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5719           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5720           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5721               E_theta)
5722           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5723               E_tc)
5724         else if (theta(i).lt.delta) then
5725           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5726           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5727           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5728               E_theta)
5729           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5730           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5731               E_tc)
5732         else
5733           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5734               E_theta,E_tc)
5735         endif
5736         etheta=etheta+ethetai
5737         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5738             'ebend',i,ethetai
5739         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5740         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5741         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5742       enddo
5743 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5744
5745 ! Ufff.... We've done all this!!!
5746       return
5747       end subroutine ebend
5748 !-----------------------------------------------------------------------------
5749       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5750
5751       use comm_calcthet
5752 !      implicit real*8 (a-h,o-z)
5753 !      include 'DIMENSIONS'
5754 !      include 'COMMON.LOCAL'
5755 !      include 'COMMON.IOUNITS'
5756 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5757 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5758 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5759       integer :: i,j,k
5760       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5761 !el      integer :: it
5762 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5763 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5764 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5765 !el local variables
5766       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5767        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5768
5769 ! Calculate the contributions to both Gaussian lobes.
5770 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5771 ! The "polynomial part" of the "standard deviation" of this part of
5772 ! the distribution.
5773         sig=polthet(3,it)
5774         do j=2,0,-1
5775           sig=sig*thet_pred_mean+polthet(j,it)
5776         enddo
5777 ! Derivative of the "interior part" of the "standard deviation of the"
5778 ! gamma-dependent Gaussian lobe in t_c.
5779         sigtc=3*polthet(3,it)
5780         do j=2,1,-1
5781           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5782         enddo
5783         sigtc=sig*sigtc
5784 ! Set the parameters of both Gaussian lobes of the distribution.
5785 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5786         fac=sig*sig+sigc0(it)
5787         sigcsq=fac+fac
5788         sigc=1.0D0/sigcsq
5789 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5790         sigsqtc=-4.0D0*sigcsq*sigtc
5791 !       print *,i,sig,sigtc,sigsqtc
5792 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5793         sigtc=-sigtc/(fac*fac)
5794 ! Following variable is sigma(t_c)**(-2)
5795         sigcsq=sigcsq*sigcsq
5796         sig0i=sig0(it)
5797         sig0inv=1.0D0/sig0i**2
5798         delthec=thetai-thet_pred_mean
5799         delthe0=thetai-theta0i
5800         term1=-0.5D0*sigcsq*delthec*delthec
5801         term2=-0.5D0*sig0inv*delthe0*delthe0
5802 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5803 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5804 ! to the energy (this being the log of the distribution) at the end of energy
5805 ! term evaluation for this virtual-bond angle.
5806         if (term1.gt.term2) then
5807           termm=term1
5808           term2=dexp(term2-termm)
5809           term1=1.0d0
5810         else
5811           termm=term2
5812           term1=dexp(term1-termm)
5813           term2=1.0d0
5814         endif
5815 ! The ratio between the gamma-independent and gamma-dependent lobes of
5816 ! the distribution is a Gaussian function of thet_pred_mean too.
5817         diffak=gthet(2,it)-thet_pred_mean
5818         ratak=diffak/gthet(3,it)**2
5819         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5820 ! Let's differentiate it in thet_pred_mean NOW.
5821         aktc=ak*ratak
5822 ! Now put together the distribution terms to make complete distribution.
5823         termexp=term1+ak*term2
5824         termpre=sigc+ak*sig0i
5825 ! Contribution of the bending energy from this theta is just the -log of
5826 ! the sum of the contributions from the two lobes and the pre-exponential
5827 ! factor. Simple enough, isn't it?
5828         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5829 ! NOW the derivatives!!!
5830 ! 6/6/97 Take into account the deformation.
5831         E_theta=(delthec*sigcsq*term1 &
5832              +ak*delthe0*sig0inv*term2)/termexp
5833         E_tc=((sigtc+aktc*sig0i)/termpre &
5834             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5835              aktc*term2)/termexp)
5836       return
5837       end subroutine theteng
5838 #else
5839 !-----------------------------------------------------------------------------
5840       subroutine ebend(etheta,ethetacnstr)
5841 !
5842 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5843 ! angles gamma and its derivatives in consecutive thetas and gammas.
5844 ! ab initio-derived potentials from
5845 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5846 !
5847 !      implicit real*8 (a-h,o-z)
5848 !      include 'DIMENSIONS'
5849 !      include 'COMMON.LOCAL'
5850 !      include 'COMMON.GEO'
5851 !      include 'COMMON.INTERACT'
5852 !      include 'COMMON.DERIV'
5853 !      include 'COMMON.VAR'
5854 !      include 'COMMON.CHAIN'
5855 !      include 'COMMON.IOUNITS'
5856 !      include 'COMMON.NAMES'
5857 !      include 'COMMON.FFIELD'
5858 !      include 'COMMON.CONTROL'
5859       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5860       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5861       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5862       logical :: lprn=.false., lprn1=.false.
5863 !el local variables
5864       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5865       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5866       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
5867 ! local variables for constrains
5868       real(kind=8) :: difi,thetiii
5869        integer itheta
5870
5871       etheta=0.0D0
5872       do i=ithet_start,ithet_end
5873         if (itype(i-1,1).eq.ntyp1) cycle
5874         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
5875         if (iabs(itype(i+1,1)).eq.20) iblock=2
5876         if (iabs(itype(i+1,1)).ne.20) iblock=1
5877         dethetai=0.0d0
5878         dephii=0.0d0
5879         dephii1=0.0d0
5880         theti2=0.5d0*theta(i)
5881         ityp2=ithetyp((itype(i-1,1)))
5882         do k=1,nntheterm
5883           coskt(k)=dcos(k*theti2)
5884           sinkt(k)=dsin(k*theti2)
5885         enddo
5886         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
5887 #ifdef OSF
5888           phii=phi(i)
5889           if (phii.ne.phii) phii=150.0
5890 #else
5891           phii=phi(i)
5892 #endif
5893           ityp1=ithetyp((itype(i-2,1)))
5894 ! propagation of chirality for glycine type
5895           do k=1,nsingle
5896             cosph1(k)=dcos(k*phii)
5897             sinph1(k)=dsin(k*phii)
5898           enddo
5899         else
5900           phii=0.0d0
5901           ityp1=ithetyp(itype(i-2,1))
5902           do k=1,nsingle
5903             cosph1(k)=0.0d0
5904             sinph1(k)=0.0d0
5905           enddo
5906         endif
5907         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
5908 #ifdef OSF
5909           phii1=phi(i+1)
5910           if (phii1.ne.phii1) phii1=150.0
5911           phii1=pinorm(phii1)
5912 #else
5913           phii1=phi(i+1)
5914 #endif
5915           ityp3=ithetyp((itype(i,1)))
5916           do k=1,nsingle
5917             cosph2(k)=dcos(k*phii1)
5918             sinph2(k)=dsin(k*phii1)
5919           enddo
5920         else
5921           phii1=0.0d0
5922           ityp3=ithetyp(itype(i,1))
5923           do k=1,nsingle
5924             cosph2(k)=0.0d0
5925             sinph2(k)=0.0d0
5926           enddo
5927         endif
5928         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5929         do k=1,ndouble
5930           do l=1,k-1
5931             ccl=cosph1(l)*cosph2(k-l)
5932             ssl=sinph1(l)*sinph2(k-l)
5933             scl=sinph1(l)*cosph2(k-l)
5934             csl=cosph1(l)*sinph2(k-l)
5935             cosph1ph2(l,k)=ccl-ssl
5936             cosph1ph2(k,l)=ccl+ssl
5937             sinph1ph2(l,k)=scl+csl
5938             sinph1ph2(k,l)=scl-csl
5939           enddo
5940         enddo
5941         if (lprn) then
5942         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
5943           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5944         write (iout,*) "coskt and sinkt"
5945         do k=1,nntheterm
5946           write (iout,*) k,coskt(k),sinkt(k)
5947         enddo
5948         endif
5949         do k=1,ntheterm
5950           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5951           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
5952             *coskt(k)
5953           if (lprn) &
5954           write (iout,*) "k",k,&
5955            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
5956            " ethetai",ethetai
5957         enddo
5958         if (lprn) then
5959         write (iout,*) "cosph and sinph"
5960         do k=1,nsingle
5961           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5962         enddo
5963         write (iout,*) "cosph1ph2 and sinph2ph2"
5964         do k=2,ndouble
5965           do l=1,k-1
5966             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
5967                sinph1ph2(l,k),sinph1ph2(k,l)
5968           enddo
5969         enddo
5970         write(iout,*) "ethetai",ethetai
5971         endif
5972         do m=1,ntheterm2
5973           do k=1,nsingle
5974             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
5975                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
5976                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
5977                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5978             ethetai=ethetai+sinkt(m)*aux
5979             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5980             dephii=dephii+k*sinkt(m)* &
5981                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
5982                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5983             dephii1=dephii1+k*sinkt(m)* &
5984                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
5985                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5986             if (lprn) &
5987             write (iout,*) "m",m," k",k," bbthet", &
5988                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
5989                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
5990                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
5991                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5992           enddo
5993         enddo
5994         if (lprn) &
5995         write(iout,*) "ethetai",ethetai
5996         do m=1,ntheterm3
5997           do k=2,ndouble
5998             do l=1,k-1
5999               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6000                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
6001                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6002                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6003               ethetai=ethetai+sinkt(m)*aux
6004               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6005               dephii=dephii+l*sinkt(m)* &
6006                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
6007                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6008                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6009                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6010               dephii1=dephii1+(k-l)*sinkt(m)* &
6011                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6012                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6013                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
6014                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6015               if (lprn) then
6016               write (iout,*) "m",m," k",k," l",l," ffthet",&
6017                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6018                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
6019                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6020                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
6021                   " ethetai",ethetai
6022               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
6023                   cosph1ph2(k,l)*sinkt(m),&
6024                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6025               endif
6026             enddo
6027           enddo
6028         enddo
6029 10      continue
6030 !        lprn1=.true.
6031         if (lprn1) &
6032           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
6033          i,theta(i)*rad2deg,phii*rad2deg,&
6034          phii1*rad2deg,ethetai
6035 !        lprn1=.false.
6036         etheta=etheta+ethetai
6037         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6038                                     'ebend',i,ethetai
6039         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6040         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6041         gloc(nphi+i-2,icg)=wang*dethetai
6042       enddo
6043 !-----------thete constrains
6044 !      if (tor_mode.ne.2) then
6045       ethetacnstr=0.0d0
6046 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6047       do i=ithetaconstr_start,ithetaconstr_end
6048         itheta=itheta_constr(i)
6049         thetiii=theta(itheta)
6050         difi=pinorm(thetiii-theta_constr0(i))
6051         if (difi.gt.theta_drange(i)) then
6052           difi=difi-theta_drange(i)
6053           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6054           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
6055          +for_thet_constr(i)*difi**3
6056         else if (difi.lt.-drange(i)) then
6057           difi=difi+drange(i)
6058           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6059           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
6060          +for_thet_constr(i)*difi**3
6061         else
6062           difi=0.0
6063         endif
6064        if (energy_dec) then
6065         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", &
6066          i,itheta,rad2deg*thetiii, &
6067          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i), &
6068          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, &
6069          gloc(itheta+nphi-2,icg)
6070         endif
6071       enddo
6072 !      endif
6073
6074       return
6075       end subroutine ebend
6076 #endif
6077 #ifdef CRYST_SC
6078 !-----------------------------------------------------------------------------
6079       subroutine esc(escloc)
6080 ! Calculate the local energy of a side chain and its derivatives in the
6081 ! corresponding virtual-bond valence angles THETA and the spherical angles
6082 ! ALPHA and OMEGA.
6083 !
6084       use comm_sccalc
6085 !      implicit real*8 (a-h,o-z)
6086 !      include 'DIMENSIONS'
6087 !      include 'COMMON.GEO'
6088 !      include 'COMMON.LOCAL'
6089 !      include 'COMMON.VAR'
6090 !      include 'COMMON.INTERACT'
6091 !      include 'COMMON.DERIV'
6092 !      include 'COMMON.CHAIN'
6093 !      include 'COMMON.IOUNITS'
6094 !      include 'COMMON.NAMES'
6095 !      include 'COMMON.FFIELD'
6096 !      include 'COMMON.CONTROL'
6097       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
6098          ddersc0,ddummy,xtemp,temp
6099 !el      real(kind=8) :: time11,time12,time112,theti
6100       real(kind=8) :: escloc,delta
6101 !el      integer :: it,nlobit
6102 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6103 !el local variables
6104       integer :: i,k
6105       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
6106        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6107       delta=0.02d0*pi
6108       escloc=0.0D0
6109 !     write (iout,'(a)') 'ESC'
6110       do i=loc_start,loc_end
6111         it=itype(i,1)
6112         if (it.eq.ntyp1) cycle
6113         if (it.eq.10) goto 1
6114         nlobit=nlob(iabs(it))
6115 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
6116 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6117         theti=theta(i+1)-pipol
6118         x(1)=dtan(theti)
6119         x(2)=alph(i)
6120         x(3)=omeg(i)
6121
6122         if (x(2).gt.pi-delta) then
6123           xtemp(1)=x(1)
6124           xtemp(2)=pi-delta
6125           xtemp(3)=x(3)
6126           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6127           xtemp(2)=pi
6128           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6129           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
6130               escloci,dersc(2))
6131           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6132               ddersc0(1),dersc(1))
6133           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
6134               ddersc0(3),dersc(3))
6135           xtemp(2)=pi-delta
6136           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6137           xtemp(2)=pi
6138           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6139           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6140                   dersc0(2),esclocbi,dersc02)
6141           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6142                   dersc12,dersc01)
6143           call splinthet(x(2),0.5d0*delta,ss,ssd)
6144           dersc0(1)=dersc01
6145           dersc0(2)=dersc02
6146           dersc0(3)=0.0d0
6147           do k=1,3
6148             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6149           enddo
6150           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6151 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6152 !    &             esclocbi,ss,ssd
6153           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6154 !         escloci=esclocbi
6155 !         write (iout,*) escloci
6156         else if (x(2).lt.delta) then
6157           xtemp(1)=x(1)
6158           xtemp(2)=delta
6159           xtemp(3)=x(3)
6160           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6161           xtemp(2)=0.0d0
6162           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6163           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6164               escloci,dersc(2))
6165           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6166               ddersc0(1),dersc(1))
6167           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6168               ddersc0(3),dersc(3))
6169           xtemp(2)=delta
6170           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6171           xtemp(2)=0.0d0
6172           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6173           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6174                   dersc0(2),esclocbi,dersc02)
6175           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6176                   dersc12,dersc01)
6177           dersc0(1)=dersc01
6178           dersc0(2)=dersc02
6179           dersc0(3)=0.0d0
6180           call splinthet(x(2),0.5d0*delta,ss,ssd)
6181           do k=1,3
6182             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6183           enddo
6184           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6185 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6186 !    &             esclocbi,ss,ssd
6187           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6188 !         write (iout,*) escloci
6189         else
6190           call enesc(x,escloci,dersc,ddummy,.false.)
6191         endif
6192
6193         escloc=escloc+escloci
6194         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6195            'escloc',i,escloci
6196 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6197
6198         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6199          wscloc*dersc(1)
6200         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6201         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6202     1   continue
6203       enddo
6204       return
6205       end subroutine esc
6206 !-----------------------------------------------------------------------------
6207       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6208
6209       use comm_sccalc
6210 !      implicit real*8 (a-h,o-z)
6211 !      include 'DIMENSIONS'
6212 !      include 'COMMON.GEO'
6213 !      include 'COMMON.LOCAL'
6214 !      include 'COMMON.IOUNITS'
6215 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6216       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6217       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6218       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6219       real(kind=8) :: escloci
6220       logical :: mixed
6221 !el local variables
6222       integer :: j,iii,l,k !el,it,nlobit
6223       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6224 !el       time11,time12,time112
6225 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6226         escloc_i=0.0D0
6227         do j=1,3
6228           dersc(j)=0.0D0
6229           if (mixed) ddersc(j)=0.0d0
6230         enddo
6231         x3=x(3)
6232
6233 ! Because of periodicity of the dependence of the SC energy in omega we have
6234 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6235 ! To avoid underflows, first compute & store the exponents.
6236
6237         do iii=-1,1
6238
6239           x(3)=x3+iii*dwapi
6240
6241           do j=1,nlobit
6242             do k=1,3
6243               z(k)=x(k)-censc(k,j,it)
6244             enddo
6245             do k=1,3
6246               Axk=0.0D0
6247               do l=1,3
6248                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6249               enddo
6250               Ax(k,j,iii)=Axk
6251             enddo
6252             expfac=0.0D0
6253             do k=1,3
6254               expfac=expfac+Ax(k,j,iii)*z(k)
6255             enddo
6256             contr(j,iii)=expfac
6257           enddo ! j
6258
6259         enddo ! iii
6260
6261         x(3)=x3
6262 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6263 ! subsequent NaNs and INFs in energy calculation.
6264 ! Find the largest exponent
6265         emin=contr(1,-1)
6266         do iii=-1,1
6267           do j=1,nlobit
6268             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6269           enddo
6270         enddo
6271         emin=0.5D0*emin
6272 !d      print *,'it=',it,' emin=',emin
6273
6274 ! Compute the contribution to SC energy and derivatives
6275         do iii=-1,1
6276
6277           do j=1,nlobit
6278 #ifdef OSF
6279             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6280             if(adexp.ne.adexp) adexp=1.0
6281             expfac=dexp(adexp)
6282 #else
6283             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6284 #endif
6285 !d          print *,'j=',j,' expfac=',expfac
6286             escloc_i=escloc_i+expfac
6287             do k=1,3
6288               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6289             enddo
6290             if (mixed) then
6291               do k=1,3,2
6292                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6293                   +gaussc(k,2,j,it))*expfac
6294               enddo
6295             endif
6296           enddo
6297
6298         enddo ! iii
6299
6300         dersc(1)=dersc(1)/cos(theti)**2
6301         ddersc(1)=ddersc(1)/cos(theti)**2
6302         ddersc(3)=ddersc(3)
6303
6304         escloci=-(dlog(escloc_i)-emin)
6305         do j=1,3
6306           dersc(j)=dersc(j)/escloc_i
6307         enddo
6308         if (mixed) then
6309           do j=1,3,2
6310             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6311           enddo
6312         endif
6313       return
6314       end subroutine enesc
6315 !-----------------------------------------------------------------------------
6316       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6317
6318       use comm_sccalc
6319 !      implicit real*8 (a-h,o-z)
6320 !      include 'DIMENSIONS'
6321 !      include 'COMMON.GEO'
6322 !      include 'COMMON.LOCAL'
6323 !      include 'COMMON.IOUNITS'
6324 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6325       real(kind=8),dimension(3) :: x,z,dersc
6326       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6327       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6328       real(kind=8) :: escloci,dersc12,emin
6329       logical :: mixed
6330 !el local varables
6331       integer :: j,k,l !el,it,nlobit
6332       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6333
6334       escloc_i=0.0D0
6335
6336       do j=1,3
6337         dersc(j)=0.0D0
6338       enddo
6339
6340       do j=1,nlobit
6341         do k=1,2
6342           z(k)=x(k)-censc(k,j,it)
6343         enddo
6344         z(3)=dwapi
6345         do k=1,3
6346           Axk=0.0D0
6347           do l=1,3
6348             Axk=Axk+gaussc(l,k,j,it)*z(l)
6349           enddo
6350           Ax(k,j)=Axk
6351         enddo
6352         expfac=0.0D0
6353         do k=1,3
6354           expfac=expfac+Ax(k,j)*z(k)
6355         enddo
6356         contr(j)=expfac
6357       enddo ! j
6358
6359 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6360 ! subsequent NaNs and INFs in energy calculation.
6361 ! Find the largest exponent
6362       emin=contr(1)
6363       do j=1,nlobit
6364         if (emin.gt.contr(j)) emin=contr(j)
6365       enddo
6366       emin=0.5D0*emin
6367
6368 ! Compute the contribution to SC energy and derivatives
6369
6370       dersc12=0.0d0
6371       do j=1,nlobit
6372         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6373         escloc_i=escloc_i+expfac
6374         do k=1,2
6375           dersc(k)=dersc(k)+Ax(k,j)*expfac
6376         enddo
6377         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6378                   +gaussc(1,2,j,it))*expfac
6379         dersc(3)=0.0d0
6380       enddo
6381
6382       dersc(1)=dersc(1)/cos(theti)**2
6383       dersc12=dersc12/cos(theti)**2
6384       escloci=-(dlog(escloc_i)-emin)
6385       do j=1,2
6386         dersc(j)=dersc(j)/escloc_i
6387       enddo
6388       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6389       return
6390       end subroutine enesc_bound
6391 #else
6392 !-----------------------------------------------------------------------------
6393       subroutine esc(escloc)
6394 ! Calculate the local energy of a side chain and its derivatives in the
6395 ! corresponding virtual-bond valence angles THETA and the spherical angles
6396 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6397 ! added by Urszula Kozlowska. 07/11/2007
6398 !
6399       use comm_sccalc
6400 !      implicit real*8 (a-h,o-z)
6401 !      include 'DIMENSIONS'
6402 !      include 'COMMON.GEO'
6403 !      include 'COMMON.LOCAL'
6404 !      include 'COMMON.VAR'
6405 !      include 'COMMON.SCROT'
6406 !      include 'COMMON.INTERACT'
6407 !      include 'COMMON.DERIV'
6408 !      include 'COMMON.CHAIN'
6409 !      include 'COMMON.IOUNITS'
6410 !      include 'COMMON.NAMES'
6411 !      include 'COMMON.FFIELD'
6412 !      include 'COMMON.CONTROL'
6413 !      include 'COMMON.VECTORS'
6414       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6415       real(kind=8),dimension(65) :: x
6416       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6417          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6418       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6419       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6420          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6421 !el local variables
6422       integer :: i,j,k !el,it,nlobit
6423       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6424 !el      real(kind=8) :: time11,time12,time112,theti
6425 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6426       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6427                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6428                    sumene1x,sumene2x,sumene3x,sumene4x,&
6429                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6430                    cosfac2xx,sinfac2yy
6431 #ifdef DEBUG
6432       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6433                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6434                    de_dt_num
6435 #endif
6436 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6437
6438       delta=0.02d0*pi
6439       escloc=0.0D0
6440       do i=loc_start,loc_end
6441         if (itype(i,1).eq.ntyp1) cycle
6442         costtab(i+1) =dcos(theta(i+1))
6443         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6444         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6445         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6446         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6447         cosfac=dsqrt(cosfac2)
6448         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6449         sinfac=dsqrt(sinfac2)
6450         it=iabs(itype(i,1))
6451         if (it.eq.10) goto 1
6452 !
6453 !  Compute the axes of tghe local cartesian coordinates system; store in
6454 !   x_prime, y_prime and z_prime
6455 !
6456         do j=1,3
6457           x_prime(j) = 0.00
6458           y_prime(j) = 0.00
6459           z_prime(j) = 0.00
6460         enddo
6461 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6462 !     &   dc_norm(3,i+nres)
6463         do j = 1,3
6464           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6465           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6466         enddo
6467         do j = 1,3
6468           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6469         enddo
6470 !       write (2,*) "i",i
6471 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6472 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6473 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6474 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6475 !      & " xy",scalar(x_prime(1),y_prime(1)),
6476 !      & " xz",scalar(x_prime(1),z_prime(1)),
6477 !      & " yy",scalar(y_prime(1),y_prime(1)),
6478 !      & " yz",scalar(y_prime(1),z_prime(1)),
6479 !      & " zz",scalar(z_prime(1),z_prime(1))
6480 !
6481 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6482 ! to local coordinate system. Store in xx, yy, zz.
6483 !
6484         xx=0.0d0
6485         yy=0.0d0
6486         zz=0.0d0
6487         do j = 1,3
6488           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6489           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6490           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6491         enddo
6492
6493         xxtab(i)=xx
6494         yytab(i)=yy
6495         zztab(i)=zz
6496 !
6497 ! Compute the energy of the ith side cbain
6498 !
6499 !        write (2,*) "xx",xx," yy",yy," zz",zz
6500         it=iabs(itype(i,1))
6501         do j = 1,65
6502           x(j) = sc_parmin(j,it)
6503         enddo
6504 #ifdef CHECK_COORD
6505 !c diagnostics - remove later
6506         xx1 = dcos(alph(2))
6507         yy1 = dsin(alph(2))*dcos(omeg(2))
6508         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6509         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6510           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6511           xx1,yy1,zz1
6512 !,"  --- ", xx_w,yy_w,zz_w
6513 ! end diagnostics
6514 #endif
6515         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6516          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6517          + x(10)*yy*zz
6518         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6519          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6520          + x(20)*yy*zz
6521         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6522          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6523          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6524          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6525          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6526          +x(40)*xx*yy*zz
6527         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6528          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6529          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6530          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6531          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6532          +x(60)*xx*yy*zz
6533         dsc_i   = 0.743d0+x(61)
6534         dp2_i   = 1.9d0+x(62)
6535         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6536                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6537         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6538                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6539         s1=(1+x(63))/(0.1d0 + dscp1)
6540         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6541         s2=(1+x(65))/(0.1d0 + dscp2)
6542         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6543         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6544       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6545 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6546 !     &   sumene4,
6547 !     &   dscp1,dscp2,sumene
6548 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6549         escloc = escloc + sumene
6550 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6551 !     & ,zz,xx,yy
6552 !#define DEBUG
6553 #ifdef DEBUG
6554 !
6555 ! This section to check the numerical derivatives of the energy of ith side
6556 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6557 ! #define DEBUG in the code to turn it on.
6558 !
6559         write (2,*) "sumene               =",sumene
6560         aincr=1.0d-7
6561         xxsave=xx
6562         xx=xx+aincr
6563         write (2,*) xx,yy,zz
6564         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6565         de_dxx_num=(sumenep-sumene)/aincr
6566         xx=xxsave
6567         write (2,*) "xx+ sumene from enesc=",sumenep
6568         yysave=yy
6569         yy=yy+aincr
6570         write (2,*) xx,yy,zz
6571         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6572         de_dyy_num=(sumenep-sumene)/aincr
6573         yy=yysave
6574         write (2,*) "yy+ sumene from enesc=",sumenep
6575         zzsave=zz
6576         zz=zz+aincr
6577         write (2,*) xx,yy,zz
6578         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6579         de_dzz_num=(sumenep-sumene)/aincr
6580         zz=zzsave
6581         write (2,*) "zz+ sumene from enesc=",sumenep
6582         costsave=cost2tab(i+1)
6583         sintsave=sint2tab(i+1)
6584         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6585         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6586         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6587         de_dt_num=(sumenep-sumene)/aincr
6588         write (2,*) " t+ sumene from enesc=",sumenep
6589         cost2tab(i+1)=costsave
6590         sint2tab(i+1)=sintsave
6591 ! End of diagnostics section.
6592 #endif
6593 !
6594 ! Compute the gradient of esc
6595 !
6596 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6597         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6598         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6599         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6600         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6601         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6602         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6603         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6604         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6605         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6606            *(pom_s1/dscp1+pom_s16*dscp1**4)
6607         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6608            *(pom_s2/dscp2+pom_s26*dscp2**4)
6609         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6610         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6611         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6612         +x(40)*yy*zz
6613         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6614         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6615         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6616         +x(60)*yy*zz
6617         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6618               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6619               +(pom1+pom2)*pom_dx
6620 #ifdef DEBUG
6621         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6622 #endif
6623 !
6624         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6625         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6626         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6627         +x(40)*xx*zz
6628         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6629         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6630         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6631         +x(59)*zz**2 +x(60)*xx*zz
6632         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6633               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6634               +(pom1-pom2)*pom_dy
6635 #ifdef DEBUG
6636         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6637 #endif
6638 !
6639         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6640         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6641         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6642         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6643         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6644         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6645         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6646         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6647 #ifdef DEBUG
6648         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6649 #endif
6650 !
6651         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6652         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6653         +pom1*pom_dt1+pom2*pom_dt2
6654 #ifdef DEBUG
6655         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6656 #endif
6657 !
6658 !
6659        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6660        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6661        cosfac2xx=cosfac2*xx
6662        sinfac2yy=sinfac2*yy
6663        do k = 1,3
6664          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6665             vbld_inv(i+1)
6666          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6667             vbld_inv(i)
6668          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6669          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6670 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6671 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6672 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6673 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6674          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6675          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6676          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6677          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6678          dZZ_Ci1(k)=0.0d0
6679          dZZ_Ci(k)=0.0d0
6680          do j=1,3
6681            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6682            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6683            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6684            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6685          enddo
6686
6687          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6688          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6689          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6690          (z_prime(k)-zz*dC_norm(k,i+nres))
6691 !
6692          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6693          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6694        enddo
6695
6696        do k=1,3
6697          dXX_Ctab(k,i)=dXX_Ci(k)
6698          dXX_C1tab(k,i)=dXX_Ci1(k)
6699          dYY_Ctab(k,i)=dYY_Ci(k)
6700          dYY_C1tab(k,i)=dYY_Ci1(k)
6701          dZZ_Ctab(k,i)=dZZ_Ci(k)
6702          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6703          dXX_XYZtab(k,i)=dXX_XYZ(k)
6704          dYY_XYZtab(k,i)=dYY_XYZ(k)
6705          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6706        enddo
6707
6708        do k = 1,3
6709 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6710 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6711 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6712 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6713 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6714 !     &    dt_dci(k)
6715 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6716 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6717          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6718           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6719          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6720           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6721          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6722           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6723        enddo
6724 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6725 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6726
6727 ! to check gradient call subroutine check_grad
6728
6729     1 continue
6730       enddo
6731       return
6732       end subroutine esc
6733 !-----------------------------------------------------------------------------
6734       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6735 !      implicit none
6736       real(kind=8),dimension(65) :: x
6737       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6738         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6739
6740       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6741         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6742         + x(10)*yy*zz
6743       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6744         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6745         + x(20)*yy*zz
6746       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6747         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6748         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6749         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6750         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6751         +x(40)*xx*yy*zz
6752       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6753         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6754         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6755         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6756         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6757         +x(60)*xx*yy*zz
6758       dsc_i   = 0.743d0+x(61)
6759       dp2_i   = 1.9d0+x(62)
6760       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6761                 *(xx*cost2+yy*sint2))
6762       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6763                 *(xx*cost2-yy*sint2))
6764       s1=(1+x(63))/(0.1d0 + dscp1)
6765       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6766       s2=(1+x(65))/(0.1d0 + dscp2)
6767       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6768       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6769        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6770       enesc=sumene
6771       return
6772       end function enesc
6773 #endif
6774 !-----------------------------------------------------------------------------
6775       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6776 !
6777 ! This procedure calculates two-body contact function g(rij) and its derivative:
6778 !
6779 !           eps0ij                                     !       x < -1
6780 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6781 !            0                                         !       x > 1
6782 !
6783 ! where x=(rij-r0ij)/delta
6784 !
6785 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6786 !
6787 !      implicit none
6788       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6789       real(kind=8) :: x,x2,x4,delta
6790 !     delta=0.02D0*r0ij
6791 !      delta=0.2D0*r0ij
6792       x=(rij-r0ij)/delta
6793       if (x.lt.-1.0D0) then
6794         fcont=eps0ij
6795         fprimcont=0.0D0
6796       else if (x.le.1.0D0) then
6797         x2=x*x
6798         x4=x2*x2
6799         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6800         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6801       else
6802         fcont=0.0D0
6803         fprimcont=0.0D0
6804       endif
6805       return
6806       end subroutine gcont
6807 !-----------------------------------------------------------------------------
6808       subroutine splinthet(theti,delta,ss,ssder)
6809 !      implicit real*8 (a-h,o-z)
6810 !      include 'DIMENSIONS'
6811 !      include 'COMMON.VAR'
6812 !      include 'COMMON.GEO'
6813       real(kind=8) :: theti,delta,ss,ssder
6814       real(kind=8) :: thetup,thetlow
6815       thetup=pi-delta
6816       thetlow=delta
6817       if (theti.gt.pipol) then
6818         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6819       else
6820         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6821         ssder=-ssder
6822       endif
6823       return
6824       end subroutine splinthet
6825 !-----------------------------------------------------------------------------
6826       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6827 !      implicit none
6828       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6829       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6830       a1=fprim0*delta/(f1-f0)
6831       a2=3.0d0-2.0d0*a1
6832       a3=a1-2.0d0
6833       ksi=(x-x0)/delta
6834       ksi2=ksi*ksi
6835       ksi3=ksi2*ksi
6836       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6837       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6838       return
6839       end subroutine spline1
6840 !-----------------------------------------------------------------------------
6841       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6842 !      implicit none
6843       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6844       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6845       ksi=(x-x0)/delta
6846       ksi2=ksi*ksi
6847       ksi3=ksi2*ksi
6848       a1=fprim0x*delta
6849       a2=3*(f1x-f0x)-2*fprim0x*delta
6850       a3=fprim0x*delta-2*(f1x-f0x)
6851       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6852       return
6853       end subroutine spline2
6854 !-----------------------------------------------------------------------------
6855 #ifdef CRYST_TOR
6856 !-----------------------------------------------------------------------------
6857       subroutine etor(etors,edihcnstr)
6858 !      implicit real*8 (a-h,o-z)
6859 !      include 'DIMENSIONS'
6860 !      include 'COMMON.VAR'
6861 !      include 'COMMON.GEO'
6862 !      include 'COMMON.LOCAL'
6863 !      include 'COMMON.TORSION'
6864 !      include 'COMMON.INTERACT'
6865 !      include 'COMMON.DERIV'
6866 !      include 'COMMON.CHAIN'
6867 !      include 'COMMON.NAMES'
6868 !      include 'COMMON.IOUNITS'
6869 !      include 'COMMON.FFIELD'
6870 !      include 'COMMON.TORCNSTR'
6871 !      include 'COMMON.CONTROL'
6872       real(kind=8) :: etors,edihcnstr
6873       logical :: lprn
6874 !el local variables
6875       integer :: i,j,
6876       real(kind=8) :: phii,fac,etors_ii
6877
6878 ! Set lprn=.true. for debugging
6879       lprn=.false.
6880 !      lprn=.true.
6881       etors=0.0D0
6882       do i=iphi_start,iphi_end
6883       etors_ii=0.0D0
6884         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
6885             .or. itype(i,1).eq.ntyp1) cycle
6886         itori=itortyp(itype(i-2,1))
6887         itori1=itortyp(itype(i-1,1))
6888         phii=phi(i)
6889         gloci=0.0D0
6890 ! Proline-Proline pair is a special case...
6891         if (itori.eq.3 .and. itori1.eq.3) then
6892           if (phii.gt.-dwapi3) then
6893             cosphi=dcos(3*phii)
6894             fac=1.0D0/(1.0D0-cosphi)
6895             etorsi=v1(1,3,3)*fac
6896             etorsi=etorsi+etorsi
6897             etors=etors+etorsi-v1(1,3,3)
6898             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6899             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6900           endif
6901           do j=1,3
6902             v1ij=v1(j+1,itori,itori1)
6903             v2ij=v2(j+1,itori,itori1)
6904             cosphi=dcos(j*phii)
6905             sinphi=dsin(j*phii)
6906             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6907             if (energy_dec) etors_ii=etors_ii+ &
6908                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6909             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6910           enddo
6911         else
6912           do j=1,nterm_old
6913             v1ij=v1(j,itori,itori1)
6914             v2ij=v2(j,itori,itori1)
6915             cosphi=dcos(j*phii)
6916             sinphi=dsin(j*phii)
6917             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6918             if (energy_dec) etors_ii=etors_ii+ &
6919                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6920             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6921           enddo
6922         endif
6923         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6924              'etor',i,etors_ii
6925         if (lprn) &
6926         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6927         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6928         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6929         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6930 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6931       enddo
6932 ! 6/20/98 - dihedral angle constraints
6933       edihcnstr=0.0d0
6934       do i=1,ndih_constr
6935         itori=idih_constr(i)
6936         phii=phi(itori)
6937         difi=phii-phi0(i)
6938         if (difi.gt.drange(i)) then
6939           difi=difi-drange(i)
6940           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6941           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6942         else if (difi.lt.-drange(i)) then
6943           difi=difi+drange(i)
6944           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6945           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6946         endif
6947 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6948 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6949       enddo
6950 !      write (iout,*) 'edihcnstr',edihcnstr
6951       return
6952       end subroutine etor
6953 !-----------------------------------------------------------------------------
6954       subroutine etor_d(etors_d)
6955       real(kind=8) :: etors_d
6956       etors_d=0.0d0
6957       return
6958       end subroutine etor_d
6959 #else
6960 !-----------------------------------------------------------------------------
6961       subroutine etor(etors,edihcnstr)
6962 !      implicit real*8 (a-h,o-z)
6963 !      include 'DIMENSIONS'
6964 !      include 'COMMON.VAR'
6965 !      include 'COMMON.GEO'
6966 !      include 'COMMON.LOCAL'
6967 !      include 'COMMON.TORSION'
6968 !      include 'COMMON.INTERACT'
6969 !      include 'COMMON.DERIV'
6970 !      include 'COMMON.CHAIN'
6971 !      include 'COMMON.NAMES'
6972 !      include 'COMMON.IOUNITS'
6973 !      include 'COMMON.FFIELD'
6974 !      include 'COMMON.TORCNSTR'
6975 !      include 'COMMON.CONTROL'
6976       real(kind=8) :: etors,edihcnstr
6977       logical :: lprn
6978 !el local variables
6979       integer :: i,j,iblock,itori,itori1
6980       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
6981                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
6982 ! Set lprn=.true. for debugging
6983       lprn=.false.
6984 !     lprn=.true.
6985       etors=0.0D0
6986       do i=iphi_start,iphi_end
6987         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6988              .or. itype(i-3,1).eq.ntyp1 &
6989              .or. itype(i,1).eq.ntyp1) cycle
6990         etors_ii=0.0D0
6991          if (iabs(itype(i,1)).eq.20) then
6992          iblock=2
6993          else
6994          iblock=1
6995          endif
6996         itori=itortyp(itype(i-2,1))
6997         itori1=itortyp(itype(i-1,1))
6998         phii=phi(i)
6999         gloci=0.0D0
7000 ! Regular cosine and sine terms
7001         do j=1,nterm(itori,itori1,iblock)
7002           v1ij=v1(j,itori,itori1,iblock)
7003           v2ij=v2(j,itori,itori1,iblock)
7004           cosphi=dcos(j*phii)
7005           sinphi=dsin(j*phii)
7006           etors=etors+v1ij*cosphi+v2ij*sinphi
7007           if (energy_dec) etors_ii=etors_ii+ &
7008                      v1ij*cosphi+v2ij*sinphi
7009           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7010         enddo
7011 ! Lorentz terms
7012 !                         v1
7013 !  E = SUM ----------------------------------- - v1
7014 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7015 !
7016         cosphi=dcos(0.5d0*phii)
7017         sinphi=dsin(0.5d0*phii)
7018         do j=1,nlor(itori,itori1,iblock)
7019           vl1ij=vlor1(j,itori,itori1)
7020           vl2ij=vlor2(j,itori,itori1)
7021           vl3ij=vlor3(j,itori,itori1)
7022           pom=vl2ij*cosphi+vl3ij*sinphi
7023           pom1=1.0d0/(pom*pom+1.0d0)
7024           etors=etors+vl1ij*pom1
7025           if (energy_dec) etors_ii=etors_ii+ &
7026                      vl1ij*pom1
7027           pom=-pom*pom1*pom1
7028           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7029         enddo
7030 ! Subtract the constant term
7031         etors=etors-v0(itori,itori1,iblock)
7032           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7033                'etor',i,etors_ii-v0(itori,itori1,iblock)
7034         if (lprn) &
7035         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7036         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7037         (v1(j,itori,itori1,iblock),j=1,6),&
7038         (v2(j,itori,itori1,iblock),j=1,6)
7039         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7040 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7041       enddo
7042 ! 6/20/98 - dihedral angle constraints
7043       edihcnstr=0.0d0
7044 !      do i=1,ndih_constr
7045       do i=idihconstr_start,idihconstr_end
7046         itori=idih_constr(i)
7047         phii=phi(itori)
7048         difi=pinorm(phii-phi0(i))
7049         if (difi.gt.drange(i)) then
7050           difi=difi-drange(i)
7051           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7052           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7053         else if (difi.lt.-drange(i)) then
7054           difi=difi+drange(i)
7055           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7056           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7057         else
7058           difi=0.0
7059         endif
7060 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
7061 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
7062 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7063       enddo
7064 !d       write (iout,*) 'edihcnstr',edihcnstr
7065       return
7066       end subroutine etor
7067 !-----------------------------------------------------------------------------
7068       subroutine etor_d(etors_d)
7069 ! 6/23/01 Compute double torsional energy
7070 !      implicit real*8 (a-h,o-z)
7071 !      include 'DIMENSIONS'
7072 !      include 'COMMON.VAR'
7073 !      include 'COMMON.GEO'
7074 !      include 'COMMON.LOCAL'
7075 !      include 'COMMON.TORSION'
7076 !      include 'COMMON.INTERACT'
7077 !      include 'COMMON.DERIV'
7078 !      include 'COMMON.CHAIN'
7079 !      include 'COMMON.NAMES'
7080 !      include 'COMMON.IOUNITS'
7081 !      include 'COMMON.FFIELD'
7082 !      include 'COMMON.TORCNSTR'
7083       real(kind=8) :: etors_d,etors_d_ii
7084       logical :: lprn
7085 !el local variables
7086       integer :: i,j,k,l,itori,itori1,itori2,iblock
7087       real(kind=8) :: phii,phii1,gloci1,gloci2,&
7088                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
7089                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
7090                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
7091 ! Set lprn=.true. for debugging
7092       lprn=.false.
7093 !     lprn=.true.
7094       etors_d=0.0D0
7095 !      write(iout,*) "a tu??"
7096       do i=iphid_start,iphid_end
7097         etors_d_ii=0.0D0
7098         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7099             .or. itype(i-3,1).eq.ntyp1 &
7100             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
7101         itori=itortyp(itype(i-2,1))
7102         itori1=itortyp(itype(i-1,1))
7103         itori2=itortyp(itype(i,1))
7104         phii=phi(i)
7105         phii1=phi(i+1)
7106         gloci1=0.0D0
7107         gloci2=0.0D0
7108         iblock=1
7109         if (iabs(itype(i+1,1)).eq.20) iblock=2
7110
7111 ! Regular cosine and sine terms
7112         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7113           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7114           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7115           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7116           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7117           cosphi1=dcos(j*phii)
7118           sinphi1=dsin(j*phii)
7119           cosphi2=dcos(j*phii1)
7120           sinphi2=dsin(j*phii1)
7121           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
7122            v2cij*cosphi2+v2sij*sinphi2
7123           if (energy_dec) etors_d_ii=etors_d_ii+ &
7124            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7125           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7126           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7127         enddo
7128         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7129           do l=1,k-1
7130             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7131             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7132             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7133             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7134             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7135             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7136             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7137             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7138             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7139               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7140             if (energy_dec) etors_d_ii=etors_d_ii+ &
7141               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7142               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7143             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7144               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7145             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7146               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7147           enddo
7148         enddo
7149         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7150                             'etor_d',i,etors_d_ii
7151         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7152         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7153       enddo
7154       return
7155       end subroutine etor_d
7156 #endif
7157 !-----------------------------------------------------------------------------
7158       subroutine eback_sc_corr(esccor)
7159 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
7160 !        conformational states; temporarily implemented as differences
7161 !        between UNRES torsional potentials (dependent on three types of
7162 !        residues) and the torsional potentials dependent on all 20 types
7163 !        of residues computed from AM1  energy surfaces of terminally-blocked
7164 !        amino-acid residues.
7165 !      implicit real*8 (a-h,o-z)
7166 !      include 'DIMENSIONS'
7167 !      include 'COMMON.VAR'
7168 !      include 'COMMON.GEO'
7169 !      include 'COMMON.LOCAL'
7170 !      include 'COMMON.TORSION'
7171 !      include 'COMMON.SCCOR'
7172 !      include 'COMMON.INTERACT'
7173 !      include 'COMMON.DERIV'
7174 !      include 'COMMON.CHAIN'
7175 !      include 'COMMON.NAMES'
7176 !      include 'COMMON.IOUNITS'
7177 !      include 'COMMON.FFIELD'
7178 !      include 'COMMON.CONTROL'
7179       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7180                    cosphi,sinphi
7181       logical :: lprn
7182       integer :: i,interty,j,isccori,isccori1,intertyp
7183 ! Set lprn=.true. for debugging
7184       lprn=.false.
7185 !      lprn=.true.
7186 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7187       esccor=0.0D0
7188       do i=itau_start,itau_end
7189         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7190         esccor_ii=0.0D0
7191         isccori=isccortyp(itype(i-2,1))
7192         isccori1=isccortyp(itype(i-1,1))
7193
7194 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7195         phii=phi(i)
7196         do intertyp=1,3 !intertyp
7197          esccor_ii=0.0D0
7198 !c Added 09 May 2012 (Adasko)
7199 !c  Intertyp means interaction type of backbone mainchain correlation:
7200 !   1 = SC...Ca...Ca...Ca
7201 !   2 = Ca...Ca...Ca...SC
7202 !   3 = SC...Ca...Ca...SCi
7203         gloci=0.0D0
7204         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7205             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7206             (itype(i-1,1).eq.ntyp1))) &
7207           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7208            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7209            .or.(itype(i,1).eq.ntyp1))) &
7210           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7211             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7212             (itype(i-3,1).eq.ntyp1)))) cycle
7213         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7214         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7215        cycle
7216        do j=1,nterm_sccor(isccori,isccori1)
7217           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7218           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7219           cosphi=dcos(j*tauangle(intertyp,i))
7220           sinphi=dsin(j*tauangle(intertyp,i))
7221           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7222           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7223           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7224         enddo
7225         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7226                                 'esccor',i,intertyp,esccor_ii
7227 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7228         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7229         if (lprn) &
7230         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7231         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7232         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7233         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7234         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7235        enddo !intertyp
7236       enddo
7237
7238       return
7239       end subroutine eback_sc_corr
7240 !-----------------------------------------------------------------------------
7241       subroutine multibody(ecorr)
7242 ! This subroutine calculates multi-body contributions to energy following
7243 ! the idea of Skolnick et al. If side chains I and J make a contact and
7244 ! at the same time side chains I+1 and J+1 make a contact, an extra
7245 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7246 !      implicit real*8 (a-h,o-z)
7247 !      include 'DIMENSIONS'
7248 !      include 'COMMON.IOUNITS'
7249 !      include 'COMMON.DERIV'
7250 !      include 'COMMON.INTERACT'
7251 !      include 'COMMON.CONTACTS'
7252       real(kind=8),dimension(3) :: gx,gx1
7253       logical :: lprn
7254       real(kind=8) :: ecorr
7255       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7256 ! Set lprn=.true. for debugging
7257       lprn=.false.
7258
7259       if (lprn) then
7260         write (iout,'(a)') 'Contact function values:'
7261         do i=nnt,nct-2
7262           write (iout,'(i2,20(1x,i2,f10.5))') &
7263               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7264         enddo
7265       endif
7266       ecorr=0.0D0
7267
7268 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7269 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7270       do i=nnt,nct
7271         do j=1,3
7272           gradcorr(j,i)=0.0D0
7273           gradxorr(j,i)=0.0D0
7274         enddo
7275       enddo
7276       do i=nnt,nct-2
7277
7278         DO ISHIFT = 3,4
7279
7280         i1=i+ishift
7281         num_conti=num_cont(i)
7282         num_conti1=num_cont(i1)
7283         do jj=1,num_conti
7284           j=jcont(jj,i)
7285           do kk=1,num_conti1
7286             j1=jcont(kk,i1)
7287             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7288 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7289 !d   &                   ' ishift=',ishift
7290 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7291 ! The system gains extra energy.
7292               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7293             endif   ! j1==j+-ishift
7294           enddo     ! kk
7295         enddo       ! jj
7296
7297         ENDDO ! ISHIFT
7298
7299       enddo         ! i
7300       return
7301       end subroutine multibody
7302 !-----------------------------------------------------------------------------
7303       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7304 !      implicit real*8 (a-h,o-z)
7305 !      include 'DIMENSIONS'
7306 !      include 'COMMON.IOUNITS'
7307 !      include 'COMMON.DERIV'
7308 !      include 'COMMON.INTERACT'
7309 !      include 'COMMON.CONTACTS'
7310       real(kind=8),dimension(3) :: gx,gx1
7311       logical :: lprn
7312       integer :: i,j,k,l,jj,kk,m,ll
7313       real(kind=8) :: eij,ekl
7314       lprn=.false.
7315       eij=facont(jj,i)
7316       ekl=facont(kk,k)
7317 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7318 ! Calculate the multi-body contribution to energy.
7319 ! Calculate multi-body contributions to the gradient.
7320 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7321 !d   & k,l,(gacont(m,kk,k),m=1,3)
7322       do m=1,3
7323         gx(m) =ekl*gacont(m,jj,i)
7324         gx1(m)=eij*gacont(m,kk,k)
7325         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7326         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7327         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7328         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7329       enddo
7330       do m=i,j-1
7331         do ll=1,3
7332           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7333         enddo
7334       enddo
7335       do m=k,l-1
7336         do ll=1,3
7337           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7338         enddo
7339       enddo
7340       esccorr=-eij*ekl
7341       return
7342       end function esccorr
7343 !-----------------------------------------------------------------------------
7344       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7345 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7346 !      implicit real*8 (a-h,o-z)
7347 !      include 'DIMENSIONS'
7348 !      include 'COMMON.IOUNITS'
7349 #ifdef MPI
7350       include "mpif.h"
7351 !      integer :: maxconts !max_cont=maxconts  =nres/4
7352       integer,parameter :: max_dim=26
7353       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7354       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7355 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7356 !el      common /przechowalnia/ zapas
7357       integer :: status(MPI_STATUS_SIZE)
7358       integer,dimension((nres/4)*2) :: req !maxconts*2
7359       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7360 #endif
7361 !      include 'COMMON.SETUP'
7362 !      include 'COMMON.FFIELD'
7363 !      include 'COMMON.DERIV'
7364 !      include 'COMMON.INTERACT'
7365 !      include 'COMMON.CONTACTS'
7366 !      include 'COMMON.CONTROL'
7367 !      include 'COMMON.LOCAL'
7368       real(kind=8),dimension(3) :: gx,gx1
7369       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7370       logical :: lprn,ldone
7371 !el local variables
7372       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7373               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7374
7375 ! Set lprn=.true. for debugging
7376       lprn=.true.
7377 #ifdef MPI
7378 !      maxconts=nres/4
7379       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7380       n_corr=0
7381       n_corr1=0
7382       if (nfgtasks.le.1) goto 30
7383       if (lprn) then
7384         write (iout,'(a)') 'Contact function values before RECEIVE:'
7385         do i=nnt,nct-2
7386           write (iout,'(2i3,50(1x,i2,f5.2))') &
7387           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7388           j=1,num_cont_hb(i))
7389         enddo
7390       endif
7391       call flush(iout)
7392       do i=1,ntask_cont_from
7393         ncont_recv(i)=0
7394       enddo
7395       do i=1,ntask_cont_to
7396         ncont_sent(i)=0
7397       enddo
7398 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7399 !     & ntask_cont_to
7400 ! Make the list of contacts to send to send to other procesors
7401 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7402 !      call flush(iout)
7403       do i=iturn3_start,iturn3_end
7404 !        write (iout,*) "make contact list turn3",i," num_cont",
7405 !     &    num_cont_hb(i)
7406         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7407       enddo
7408       do i=iturn4_start,iturn4_end
7409 !        write (iout,*) "make contact list turn4",i," num_cont",
7410 !     &   num_cont_hb(i)
7411         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7412       enddo
7413       do ii=1,nat_sent
7414         i=iat_sent(ii)
7415 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7416 !     &    num_cont_hb(i)
7417         do j=1,num_cont_hb(i)
7418         do k=1,4
7419           jjc=jcont_hb(j,i)
7420           iproc=iint_sent_local(k,jjc,ii)
7421 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7422           if (iproc.gt.0) then
7423             ncont_sent(iproc)=ncont_sent(iproc)+1
7424             nn=ncont_sent(iproc)
7425             zapas(1,nn,iproc)=i
7426             zapas(2,nn,iproc)=jjc
7427             zapas(3,nn,iproc)=facont_hb(j,i)
7428             zapas(4,nn,iproc)=ees0p(j,i)
7429             zapas(5,nn,iproc)=ees0m(j,i)
7430             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7431             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7432             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7433             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7434             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7435             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7436             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7437             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7438             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7439             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7440             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7441             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7442             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7443             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7444             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7445             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7446             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7447             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7448             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7449             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7450             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7451           endif
7452         enddo
7453         enddo
7454       enddo
7455       if (lprn) then
7456       write (iout,*) &
7457         "Numbers of contacts to be sent to other processors",&
7458         (ncont_sent(i),i=1,ntask_cont_to)
7459       write (iout,*) "Contacts sent"
7460       do ii=1,ntask_cont_to
7461         nn=ncont_sent(ii)
7462         iproc=itask_cont_to(ii)
7463         write (iout,*) nn," contacts to processor",iproc,&
7464          " of CONT_TO_COMM group"
7465         do i=1,nn
7466           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7467         enddo
7468       enddo
7469       call flush(iout)
7470       endif
7471       CorrelType=477
7472       CorrelID=fg_rank+1
7473       CorrelType1=478
7474       CorrelID1=nfgtasks+fg_rank+1
7475       ireq=0
7476 ! Receive the numbers of needed contacts from other processors
7477       do ii=1,ntask_cont_from
7478         iproc=itask_cont_from(ii)
7479         ireq=ireq+1
7480         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7481           FG_COMM,req(ireq),IERR)
7482       enddo
7483 !      write (iout,*) "IRECV ended"
7484 !      call flush(iout)
7485 ! Send the number of contacts needed by other processors
7486       do ii=1,ntask_cont_to
7487         iproc=itask_cont_to(ii)
7488         ireq=ireq+1
7489         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7490           FG_COMM,req(ireq),IERR)
7491       enddo
7492 !      write (iout,*) "ISEND ended"
7493 !      write (iout,*) "number of requests (nn)",ireq
7494       call flush(iout)
7495       if (ireq.gt.0) &
7496         call MPI_Waitall(ireq,req,status_array,ierr)
7497 !      write (iout,*)
7498 !     &  "Numbers of contacts to be received from other processors",
7499 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7500 !      call flush(iout)
7501 ! Receive contacts
7502       ireq=0
7503       do ii=1,ntask_cont_from
7504         iproc=itask_cont_from(ii)
7505         nn=ncont_recv(ii)
7506 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7507 !     &   " of CONT_TO_COMM group"
7508         call flush(iout)
7509         if (nn.gt.0) then
7510           ireq=ireq+1
7511           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7512           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7513 !          write (iout,*) "ireq,req",ireq,req(ireq)
7514         endif
7515       enddo
7516 ! Send the contacts to processors that need them
7517       do ii=1,ntask_cont_to
7518         iproc=itask_cont_to(ii)
7519         nn=ncont_sent(ii)
7520 !        write (iout,*) nn," contacts to processor",iproc,
7521 !     &   " of CONT_TO_COMM group"
7522         if (nn.gt.0) then
7523           ireq=ireq+1
7524           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7525             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7526 !          write (iout,*) "ireq,req",ireq,req(ireq)
7527 !          do i=1,nn
7528 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7529 !          enddo
7530         endif
7531       enddo
7532 !      write (iout,*) "number of requests (contacts)",ireq
7533 !      write (iout,*) "req",(req(i),i=1,4)
7534 !      call flush(iout)
7535       if (ireq.gt.0) &
7536        call MPI_Waitall(ireq,req,status_array,ierr)
7537       do iii=1,ntask_cont_from
7538         iproc=itask_cont_from(iii)
7539         nn=ncont_recv(iii)
7540         if (lprn) then
7541         write (iout,*) "Received",nn," contacts from processor",iproc,&
7542          " of CONT_FROM_COMM group"
7543         call flush(iout)
7544         do i=1,nn
7545           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7546         enddo
7547         call flush(iout)
7548         endif
7549         do i=1,nn
7550           ii=zapas_recv(1,i,iii)
7551 ! Flag the received contacts to prevent double-counting
7552           jj=-zapas_recv(2,i,iii)
7553 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7554 !          call flush(iout)
7555           nnn=num_cont_hb(ii)+1
7556           num_cont_hb(ii)=nnn
7557           jcont_hb(nnn,ii)=jj
7558           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7559           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7560           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7561           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7562           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7563           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7564           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7565           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7566           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7567           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7568           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7569           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7570           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7571           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7572           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7573           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7574           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7575           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7576           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7577           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7578           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7579           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7580           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7581           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7582         enddo
7583       enddo
7584       call flush(iout)
7585       if (lprn) then
7586         write (iout,'(a)') 'Contact function values after receive:'
7587         do i=nnt,nct-2
7588           write (iout,'(2i3,50(1x,i3,f5.2))') &
7589           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7590           j=1,num_cont_hb(i))
7591         enddo
7592         call flush(iout)
7593       endif
7594    30 continue
7595 #endif
7596       if (lprn) then
7597         write (iout,'(a)') 'Contact function values:'
7598         do i=nnt,nct-2
7599           write (iout,'(2i3,50(1x,i3,f5.2))') &
7600           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7601           j=1,num_cont_hb(i))
7602         enddo
7603       endif
7604       ecorr=0.0D0
7605
7606 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7607 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7608 ! Remove the loop below after debugging !!!
7609       do i=nnt,nct
7610         do j=1,3
7611           gradcorr(j,i)=0.0D0
7612           gradxorr(j,i)=0.0D0
7613         enddo
7614       enddo
7615 ! Calculate the local-electrostatic correlation terms
7616       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7617         i1=i+1
7618         num_conti=num_cont_hb(i)
7619         num_conti1=num_cont_hb(i+1)
7620         do jj=1,num_conti
7621           j=jcont_hb(jj,i)
7622           jp=iabs(j)
7623           do kk=1,num_conti1
7624             j1=jcont_hb(kk,i1)
7625             jp1=iabs(j1)
7626 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7627 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7628             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7629                 .or. j.lt.0 .and. j1.gt.0) .and. &
7630                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7631 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7632 ! The system gains extra energy.
7633               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7634               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7635                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7636               n_corr=n_corr+1
7637             else if (j1.eq.j) then
7638 ! Contacts I-J and I-(J+1) occur simultaneously.
7639 ! The system loses extra energy.
7640 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7641             endif
7642           enddo ! kk
7643           do kk=1,num_conti
7644             j1=jcont_hb(kk,i)
7645 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7646 !    &         ' jj=',jj,' kk=',kk
7647             if (j1.eq.j+1) then
7648 ! Contacts I-J and (I+1)-J occur simultaneously.
7649 ! The system loses extra energy.
7650 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7651             endif ! j1==j+1
7652           enddo ! kk
7653         enddo ! jj
7654       enddo ! i
7655       return
7656       end subroutine multibody_hb
7657 !-----------------------------------------------------------------------------
7658       subroutine add_hb_contact(ii,jj,itask)
7659 !      implicit real*8 (a-h,o-z)
7660 !      include "DIMENSIONS"
7661 !      include "COMMON.IOUNITS"
7662 !      include "COMMON.CONTACTS"
7663 !      integer,parameter :: maxconts=nres/4
7664       integer,parameter :: max_dim=26
7665       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7666 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7667 !      common /przechowalnia/ zapas
7668       integer :: i,j,ii,jj,iproc,nn,jjc
7669       integer,dimension(4) :: itask
7670 !      write (iout,*) "itask",itask
7671       do i=1,2
7672         iproc=itask(i)
7673         if (iproc.gt.0) then
7674           do j=1,num_cont_hb(ii)
7675             jjc=jcont_hb(j,ii)
7676 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7677             if (jjc.eq.jj) then
7678               ncont_sent(iproc)=ncont_sent(iproc)+1
7679               nn=ncont_sent(iproc)
7680               zapas(1,nn,iproc)=ii
7681               zapas(2,nn,iproc)=jjc
7682               zapas(3,nn,iproc)=facont_hb(j,ii)
7683               zapas(4,nn,iproc)=ees0p(j,ii)
7684               zapas(5,nn,iproc)=ees0m(j,ii)
7685               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7686               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7687               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7688               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7689               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7690               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7691               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7692               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7693               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7694               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7695               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7696               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7697               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7698               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7699               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7700               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7701               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7702               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7703               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7704               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7705               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7706               exit
7707             endif
7708           enddo
7709         endif
7710       enddo
7711       return
7712       end subroutine add_hb_contact
7713 !-----------------------------------------------------------------------------
7714       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7715 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7716 !      implicit real*8 (a-h,o-z)
7717 !      include 'DIMENSIONS'
7718 !      include 'COMMON.IOUNITS'
7719       integer,parameter :: max_dim=70
7720 #ifdef MPI
7721       include "mpif.h"
7722 !      integer :: maxconts !max_cont=maxconts=nres/4
7723       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7724       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7725 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7726 !      common /przechowalnia/ zapas
7727       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7728         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7729         ierr,iii,nnn
7730 #endif
7731 !      include 'COMMON.SETUP'
7732 !      include 'COMMON.FFIELD'
7733 !      include 'COMMON.DERIV'
7734 !      include 'COMMON.LOCAL'
7735 !      include 'COMMON.INTERACT'
7736 !      include 'COMMON.CONTACTS'
7737 !      include 'COMMON.CHAIN'
7738 !      include 'COMMON.CONTROL'
7739       real(kind=8),dimension(3) :: gx,gx1
7740       integer,dimension(nres) :: num_cont_hb_old
7741       logical :: lprn,ldone
7742 !EL      double precision eello4,eello5,eelo6,eello_turn6
7743 !EL      external eello4,eello5,eello6,eello_turn6
7744 !el local variables
7745       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7746               j1,jp1,i1,num_conti1
7747       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7748       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7749
7750 ! Set lprn=.true. for debugging
7751       lprn=.false.
7752       eturn6=0.0d0
7753 #ifdef MPI
7754 !      maxconts=nres/4
7755       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7756       do i=1,nres
7757         num_cont_hb_old(i)=num_cont_hb(i)
7758       enddo
7759       n_corr=0
7760       n_corr1=0
7761       if (nfgtasks.le.1) goto 30
7762       if (lprn) then
7763         write (iout,'(a)') 'Contact function values before RECEIVE:'
7764         do i=nnt,nct-2
7765           write (iout,'(2i3,50(1x,i2,f5.2))') &
7766           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7767           j=1,num_cont_hb(i))
7768         enddo
7769       endif
7770       call flush(iout)
7771       do i=1,ntask_cont_from
7772         ncont_recv(i)=0
7773       enddo
7774       do i=1,ntask_cont_to
7775         ncont_sent(i)=0
7776       enddo
7777 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7778 !     & ntask_cont_to
7779 ! Make the list of contacts to send to send to other procesors
7780       do i=iturn3_start,iturn3_end
7781 !        write (iout,*) "make contact list turn3",i," num_cont",
7782 !     &    num_cont_hb(i)
7783         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7784       enddo
7785       do i=iturn4_start,iturn4_end
7786 !        write (iout,*) "make contact list turn4",i," num_cont",
7787 !     &   num_cont_hb(i)
7788         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7789       enddo
7790       do ii=1,nat_sent
7791         i=iat_sent(ii)
7792 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7793 !     &    num_cont_hb(i)
7794         do j=1,num_cont_hb(i)
7795         do k=1,4
7796           jjc=jcont_hb(j,i)
7797           iproc=iint_sent_local(k,jjc,ii)
7798 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7799           if (iproc.ne.0) then
7800             ncont_sent(iproc)=ncont_sent(iproc)+1
7801             nn=ncont_sent(iproc)
7802             zapas(1,nn,iproc)=i
7803             zapas(2,nn,iproc)=jjc
7804             zapas(3,nn,iproc)=d_cont(j,i)
7805             ind=3
7806             do kk=1,3
7807               ind=ind+1
7808               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7809             enddo
7810             do kk=1,2
7811               do ll=1,2
7812                 ind=ind+1
7813                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7814               enddo
7815             enddo
7816             do jj=1,5
7817               do kk=1,3
7818                 do ll=1,2
7819                   do mm=1,2
7820                     ind=ind+1
7821                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7822                   enddo
7823                 enddo
7824               enddo
7825             enddo
7826           endif
7827         enddo
7828         enddo
7829       enddo
7830       if (lprn) then
7831       write (iout,*) &
7832         "Numbers of contacts to be sent to other processors",&
7833         (ncont_sent(i),i=1,ntask_cont_to)
7834       write (iout,*) "Contacts sent"
7835       do ii=1,ntask_cont_to
7836         nn=ncont_sent(ii)
7837         iproc=itask_cont_to(ii)
7838         write (iout,*) nn," contacts to processor",iproc,&
7839          " of CONT_TO_COMM group"
7840         do i=1,nn
7841           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7842         enddo
7843       enddo
7844       call flush(iout)
7845       endif
7846       CorrelType=477
7847       CorrelID=fg_rank+1
7848       CorrelType1=478
7849       CorrelID1=nfgtasks+fg_rank+1
7850       ireq=0
7851 ! Receive the numbers of needed contacts from other processors
7852       do ii=1,ntask_cont_from
7853         iproc=itask_cont_from(ii)
7854         ireq=ireq+1
7855         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7856           FG_COMM,req(ireq),IERR)
7857       enddo
7858 !      write (iout,*) "IRECV ended"
7859 !      call flush(iout)
7860 ! Send the number of contacts needed by other processors
7861       do ii=1,ntask_cont_to
7862         iproc=itask_cont_to(ii)
7863         ireq=ireq+1
7864         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7865           FG_COMM,req(ireq),IERR)
7866       enddo
7867 !      write (iout,*) "ISEND ended"
7868 !      write (iout,*) "number of requests (nn)",ireq
7869       call flush(iout)
7870       if (ireq.gt.0) &
7871         call MPI_Waitall(ireq,req,status_array,ierr)
7872 !      write (iout,*)
7873 !     &  "Numbers of contacts to be received from other processors",
7874 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7875 !      call flush(iout)
7876 ! Receive contacts
7877       ireq=0
7878       do ii=1,ntask_cont_from
7879         iproc=itask_cont_from(ii)
7880         nn=ncont_recv(ii)
7881 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7882 !     &   " of CONT_TO_COMM group"
7883         call flush(iout)
7884         if (nn.gt.0) then
7885           ireq=ireq+1
7886           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7887           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7888 !          write (iout,*) "ireq,req",ireq,req(ireq)
7889         endif
7890       enddo
7891 ! Send the contacts to processors that need them
7892       do ii=1,ntask_cont_to
7893         iproc=itask_cont_to(ii)
7894         nn=ncont_sent(ii)
7895 !        write (iout,*) nn," contacts to processor",iproc,
7896 !     &   " of CONT_TO_COMM group"
7897         if (nn.gt.0) then
7898           ireq=ireq+1
7899           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7900             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7901 !          write (iout,*) "ireq,req",ireq,req(ireq)
7902 !          do i=1,nn
7903 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7904 !          enddo
7905         endif
7906       enddo
7907 !      write (iout,*) "number of requests (contacts)",ireq
7908 !      write (iout,*) "req",(req(i),i=1,4)
7909 !      call flush(iout)
7910       if (ireq.gt.0) &
7911        call MPI_Waitall(ireq,req,status_array,ierr)
7912       do iii=1,ntask_cont_from
7913         iproc=itask_cont_from(iii)
7914         nn=ncont_recv(iii)
7915         if (lprn) then
7916         write (iout,*) "Received",nn," contacts from processor",iproc,&
7917          " of CONT_FROM_COMM group"
7918         call flush(iout)
7919         do i=1,nn
7920           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7921         enddo
7922         call flush(iout)
7923         endif
7924         do i=1,nn
7925           ii=zapas_recv(1,i,iii)
7926 ! Flag the received contacts to prevent double-counting
7927           jj=-zapas_recv(2,i,iii)
7928 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7929 !          call flush(iout)
7930           nnn=num_cont_hb(ii)+1
7931           num_cont_hb(ii)=nnn
7932           jcont_hb(nnn,ii)=jj
7933           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7934           ind=3
7935           do kk=1,3
7936             ind=ind+1
7937             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7938           enddo
7939           do kk=1,2
7940             do ll=1,2
7941               ind=ind+1
7942               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7943             enddo
7944           enddo
7945           do jj=1,5
7946             do kk=1,3
7947               do ll=1,2
7948                 do mm=1,2
7949                   ind=ind+1
7950                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7951                 enddo
7952               enddo
7953             enddo
7954           enddo
7955         enddo
7956       enddo
7957       call flush(iout)
7958       if (lprn) then
7959         write (iout,'(a)') 'Contact function values after receive:'
7960         do i=nnt,nct-2
7961           write (iout,'(2i3,50(1x,i3,5f6.3))') &
7962           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7963           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7964         enddo
7965         call flush(iout)
7966       endif
7967    30 continue
7968 #endif
7969       if (lprn) then
7970         write (iout,'(a)') 'Contact function values:'
7971         do i=nnt,nct-2
7972           write (iout,'(2i3,50(1x,i2,5f6.3))') &
7973           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7974           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7975         enddo
7976       endif
7977       ecorr=0.0D0
7978       ecorr5=0.0d0
7979       ecorr6=0.0d0
7980
7981 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7982 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7983 ! Remove the loop below after debugging !!!
7984       do i=nnt,nct
7985         do j=1,3
7986           gradcorr(j,i)=0.0D0
7987           gradxorr(j,i)=0.0D0
7988         enddo
7989       enddo
7990 ! Calculate the dipole-dipole interaction energies
7991       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7992       do i=iatel_s,iatel_e+1
7993         num_conti=num_cont_hb(i)
7994         do jj=1,num_conti
7995           j=jcont_hb(jj,i)
7996 #ifdef MOMENT
7997           call dipole(i,j,jj)
7998 #endif
7999         enddo
8000       enddo
8001       endif
8002 ! Calculate the local-electrostatic correlation terms
8003 !                write (iout,*) "gradcorr5 in eello5 before loop"
8004 !                do iii=1,nres
8005 !                  write (iout,'(i5,3f10.5)')
8006 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8007 !                enddo
8008       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8009 !        write (iout,*) "corr loop i",i
8010         i1=i+1
8011         num_conti=num_cont_hb(i)
8012         num_conti1=num_cont_hb(i+1)
8013         do jj=1,num_conti
8014           j=jcont_hb(jj,i)
8015           jp=iabs(j)
8016           do kk=1,num_conti1
8017             j1=jcont_hb(kk,i1)
8018             jp1=iabs(j1)
8019 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8020 !     &         ' jj=',jj,' kk=',kk
8021 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
8022             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8023                 .or. j.lt.0 .and. j1.gt.0) .and. &
8024                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8025 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8026 ! The system gains extra energy.
8027               n_corr=n_corr+1
8028               sqd1=dsqrt(d_cont(jj,i))
8029               sqd2=dsqrt(d_cont(kk,i1))
8030               sred_geom = sqd1*sqd2
8031               IF (sred_geom.lt.cutoff_corr) THEN
8032                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
8033                   ekont,fprimcont)
8034 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8035 !d     &         ' jj=',jj,' kk=',kk
8036                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8037                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8038                 do l=1,3
8039                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8040                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8041                 enddo
8042                 n_corr1=n_corr1+1
8043 !d               write (iout,*) 'sred_geom=',sred_geom,
8044 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
8045 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8046 !d               write (iout,*) "g_contij",g_contij
8047 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8048 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8049                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8050                 if (wcorr4.gt.0.0d0) &
8051                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8052                   if (energy_dec.and.wcorr4.gt.0.0d0) &
8053                        write (iout,'(a6,4i5,0pf7.3)') &
8054                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8055 !                write (iout,*) "gradcorr5 before eello5"
8056 !                do iii=1,nres
8057 !                  write (iout,'(i5,3f10.5)')
8058 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8059 !                enddo
8060                 if (wcorr5.gt.0.0d0) &
8061                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8062 !                write (iout,*) "gradcorr5 after eello5"
8063 !                do iii=1,nres
8064 !                  write (iout,'(i5,3f10.5)')
8065 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8066 !                enddo
8067                   if (energy_dec.and.wcorr5.gt.0.0d0) &
8068                        write (iout,'(a6,4i5,0pf7.3)') &
8069                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8070 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8071 !d                write(2,*)'ijkl',i,jp,i+1,jp1
8072                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
8073                      .or. wturn6.eq.0.0d0))then
8074 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8075                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8076                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8077                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8078 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8079 !d     &            'ecorr6=',ecorr6
8080 !d                write (iout,'(4e15.5)') sred_geom,
8081 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8082 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8083 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8084                 else if (wturn6.gt.0.0d0 &
8085                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8086 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8087                   eturn6=eturn6+eello_turn6(i,jj,kk)
8088                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8089                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8090 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
8091                 endif
8092               ENDIF
8093 1111          continue
8094             endif
8095           enddo ! kk
8096         enddo ! jj
8097       enddo ! i
8098       do i=1,nres
8099         num_cont_hb(i)=num_cont_hb_old(i)
8100       enddo
8101 !                write (iout,*) "gradcorr5 in eello5"
8102 !                do iii=1,nres
8103 !                  write (iout,'(i5,3f10.5)')
8104 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8105 !                enddo
8106       return
8107       end subroutine multibody_eello
8108 !-----------------------------------------------------------------------------
8109       subroutine add_hb_contact_eello(ii,jj,itask)
8110 !      implicit real*8 (a-h,o-z)
8111 !      include "DIMENSIONS"
8112 !      include "COMMON.IOUNITS"
8113 !      include "COMMON.CONTACTS"
8114 !      integer,parameter :: maxconts=nres/4
8115       integer,parameter :: max_dim=70
8116       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8117 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8118 !      common /przechowalnia/ zapas
8119
8120       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
8121       integer,dimension(4) ::itask
8122 !      write (iout,*) "itask",itask
8123       do i=1,2
8124         iproc=itask(i)
8125         if (iproc.gt.0) then
8126           do j=1,num_cont_hb(ii)
8127             jjc=jcont_hb(j,ii)
8128 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8129             if (jjc.eq.jj) then
8130               ncont_sent(iproc)=ncont_sent(iproc)+1
8131               nn=ncont_sent(iproc)
8132               zapas(1,nn,iproc)=ii
8133               zapas(2,nn,iproc)=jjc
8134               zapas(3,nn,iproc)=d_cont(j,ii)
8135               ind=3
8136               do kk=1,3
8137                 ind=ind+1
8138                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8139               enddo
8140               do kk=1,2
8141                 do ll=1,2
8142                   ind=ind+1
8143                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8144                 enddo
8145               enddo
8146               do jj=1,5
8147                 do kk=1,3
8148                   do ll=1,2
8149                     do mm=1,2
8150                       ind=ind+1
8151                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8152                     enddo
8153                   enddo
8154                 enddo
8155               enddo
8156               exit
8157             endif
8158           enddo
8159         endif
8160       enddo
8161       return
8162       end subroutine add_hb_contact_eello
8163 !-----------------------------------------------------------------------------
8164       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8165 !      implicit real*8 (a-h,o-z)
8166 !      include 'DIMENSIONS'
8167 !      include 'COMMON.IOUNITS'
8168 !      include 'COMMON.DERIV'
8169 !      include 'COMMON.INTERACT'
8170 !      include 'COMMON.CONTACTS'
8171       real(kind=8),dimension(3) :: gx,gx1
8172       logical :: lprn
8173 !el local variables
8174       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8175       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8176                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8177                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8178                    rlocshield
8179
8180       lprn=.false.
8181       eij=facont_hb(jj,i)
8182       ekl=facont_hb(kk,k)
8183       ees0pij=ees0p(jj,i)
8184       ees0pkl=ees0p(kk,k)
8185       ees0mij=ees0m(jj,i)
8186       ees0mkl=ees0m(kk,k)
8187       ekont=eij*ekl
8188       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8189 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8190 ! Following 4 lines for diagnostics.
8191 !d    ees0pkl=0.0D0
8192 !d    ees0pij=1.0D0
8193 !d    ees0mkl=0.0D0
8194 !d    ees0mij=1.0D0
8195 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8196 !     & 'Contacts ',i,j,
8197 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8198 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8199 !     & 'gradcorr_long'
8200 ! Calculate the multi-body contribution to energy.
8201 !      ecorr=ecorr+ekont*ees
8202 ! Calculate multi-body contributions to the gradient.
8203       coeffpees0pij=coeffp*ees0pij
8204       coeffmees0mij=coeffm*ees0mij
8205       coeffpees0pkl=coeffp*ees0pkl
8206       coeffmees0mkl=coeffm*ees0mkl
8207       do ll=1,3
8208 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8209         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8210         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8211         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8212         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8213         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8214         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8215 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8216         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8217         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8218         coeffmees0mij*gacontm_hb1(ll,kk,k))
8219         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8220         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8221         coeffmees0mij*gacontm_hb2(ll,kk,k))
8222         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8223            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8224            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8225         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8226         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8227         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8228            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8229            coeffmees0mij*gacontm_hb3(ll,kk,k))
8230         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8231         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8232 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8233       enddo
8234 !      write (iout,*)
8235 !grad      do m=i+1,j-1
8236 !grad        do ll=1,3
8237 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8238 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8239 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8240 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8241 !grad        enddo
8242 !grad      enddo
8243 !grad      do m=k+1,l-1
8244 !grad        do ll=1,3
8245 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8246 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8247 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8248 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8249 !grad        enddo
8250 !grad      enddo
8251 !      write (iout,*) "ehbcorr",ekont*ees
8252       ehbcorr=ekont*ees
8253       if (shield_mode.gt.0) then
8254        j=ees0plist(jj,i)
8255        l=ees0plist(kk,k)
8256 !C        print *,i,j,fac_shield(i),fac_shield(j),
8257 !C     &fac_shield(k),fac_shield(l)
8258         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8259            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8260           do ilist=1,ishield_list(i)
8261            iresshield=shield_list(ilist,i)
8262            do m=1,3
8263            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8264            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8265                    rlocshield  &
8266             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8267             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8268             +rlocshield
8269            enddo
8270           enddo
8271           do ilist=1,ishield_list(j)
8272            iresshield=shield_list(ilist,j)
8273            do m=1,3
8274            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8275            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8276                    rlocshield &
8277             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8278            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8279             +rlocshield
8280            enddo
8281           enddo
8282
8283           do ilist=1,ishield_list(k)
8284            iresshield=shield_list(ilist,k)
8285            do m=1,3
8286            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8287            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8288                    rlocshield &
8289             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8290            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8291             +rlocshield
8292            enddo
8293           enddo
8294           do ilist=1,ishield_list(l)
8295            iresshield=shield_list(ilist,l)
8296            do m=1,3
8297            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8298            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8299                    rlocshield &
8300             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8301            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8302             +rlocshield
8303            enddo
8304           enddo
8305           do m=1,3
8306             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8307                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8308             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8309                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8310             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8311                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8312             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8313                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8314
8315             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8316                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8317             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8318                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8319             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8320                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8321             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8322                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8323
8324            enddo
8325       endif
8326       endif
8327       return
8328       end function ehbcorr
8329 #ifdef MOMENT
8330 !-----------------------------------------------------------------------------
8331       subroutine dipole(i,j,jj)
8332 !      implicit real*8 (a-h,o-z)
8333 !      include 'DIMENSIONS'
8334 !      include 'COMMON.IOUNITS'
8335 !      include 'COMMON.CHAIN'
8336 !      include 'COMMON.FFIELD'
8337 !      include 'COMMON.DERIV'
8338 !      include 'COMMON.INTERACT'
8339 !      include 'COMMON.CONTACTS'
8340 !      include 'COMMON.TORSION'
8341 !      include 'COMMON.VAR'
8342 !      include 'COMMON.GEO'
8343       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8344       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8345       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8346
8347       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8348       allocate(dipderx(3,5,4,maxconts,nres))
8349 !
8350
8351       iti1 = itortyp(itype(i+1,1))
8352       if (j.lt.nres-1) then
8353         itj1 = itortyp(itype(j+1,1))
8354       else
8355         itj1=ntortyp+1
8356       endif
8357       do iii=1,2
8358         dipi(iii,1)=Ub2(iii,i)
8359         dipderi(iii)=Ub2der(iii,i)
8360         dipi(iii,2)=b1(iii,iti1)
8361         dipj(iii,1)=Ub2(iii,j)
8362         dipderj(iii)=Ub2der(iii,j)
8363         dipj(iii,2)=b1(iii,itj1)
8364       enddo
8365       kkk=0
8366       do iii=1,2
8367         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8368         do jjj=1,2
8369           kkk=kkk+1
8370           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8371         enddo
8372       enddo
8373       do kkk=1,5
8374         do lll=1,3
8375           mmm=0
8376           do iii=1,2
8377             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8378               auxvec(1))
8379             do jjj=1,2
8380               mmm=mmm+1
8381               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8382             enddo
8383           enddo
8384         enddo
8385       enddo
8386       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8387       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8388       do iii=1,2
8389         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8390       enddo
8391       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8392       do iii=1,2
8393         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8394       enddo
8395       return
8396       end subroutine dipole
8397 #endif
8398 !-----------------------------------------------------------------------------
8399       subroutine calc_eello(i,j,k,l,jj,kk)
8400 !
8401 ! This subroutine computes matrices and vectors needed to calculate
8402 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8403 !
8404       use comm_kut
8405 !      implicit real*8 (a-h,o-z)
8406 !      include 'DIMENSIONS'
8407 !      include 'COMMON.IOUNITS'
8408 !      include 'COMMON.CHAIN'
8409 !      include 'COMMON.DERIV'
8410 !      include 'COMMON.INTERACT'
8411 !      include 'COMMON.CONTACTS'
8412 !      include 'COMMON.TORSION'
8413 !      include 'COMMON.VAR'
8414 !      include 'COMMON.GEO'
8415 !      include 'COMMON.FFIELD'
8416       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8417       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8418       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8419               itj1
8420 !el      logical :: lprn
8421 !el      common /kutas/ lprn
8422 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8423 !d     & ' jj=',jj,' kk=',kk
8424 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8425 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8426 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8427       do iii=1,2
8428         do jjj=1,2
8429           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8430           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8431         enddo
8432       enddo
8433       call transpose2(aa1(1,1),aa1t(1,1))
8434       call transpose2(aa2(1,1),aa2t(1,1))
8435       do kkk=1,5
8436         do lll=1,3
8437           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8438             aa1tder(1,1,lll,kkk))
8439           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8440             aa2tder(1,1,lll,kkk))
8441         enddo
8442       enddo
8443       if (l.eq.j+1) then
8444 ! parallel orientation of the two CA-CA-CA frames.
8445         if (i.gt.1) then
8446           iti=itortyp(itype(i,1))
8447         else
8448           iti=ntortyp+1
8449         endif
8450         itk1=itortyp(itype(k+1,1))
8451         itj=itortyp(itype(j,1))
8452         if (l.lt.nres-1) then
8453           itl1=itortyp(itype(l+1,1))
8454         else
8455           itl1=ntortyp+1
8456         endif
8457 ! A1 kernel(j+1) A2T
8458 !d        do iii=1,2
8459 !d          write (iout,'(3f10.5,5x,3f10.5)')
8460 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8461 !d        enddo
8462         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8463          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8464          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8465 ! Following matrices are needed only for 6-th order cumulants
8466         IF (wcorr6.gt.0.0d0) THEN
8467         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8468          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8469          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8470         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8471          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8472          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8473          ADtEAderx(1,1,1,1,1,1))
8474         lprn=.false.
8475         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8476          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8477          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8478          ADtEA1derx(1,1,1,1,1,1))
8479         ENDIF
8480 ! End 6-th order cumulants
8481 !d        lprn=.false.
8482 !d        if (lprn) then
8483 !d        write (2,*) 'In calc_eello6'
8484 !d        do iii=1,2
8485 !d          write (2,*) 'iii=',iii
8486 !d          do kkk=1,5
8487 !d            write (2,*) 'kkk=',kkk
8488 !d            do jjj=1,2
8489 !d              write (2,'(3(2f10.5),5x)')
8490 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8491 !d            enddo
8492 !d          enddo
8493 !d        enddo
8494 !d        endif
8495         call transpose2(EUgder(1,1,k),auxmat(1,1))
8496         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8497         call transpose2(EUg(1,1,k),auxmat(1,1))
8498         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8499         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8500         do iii=1,2
8501           do kkk=1,5
8502             do lll=1,3
8503               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8504                 EAEAderx(1,1,lll,kkk,iii,1))
8505             enddo
8506           enddo
8507         enddo
8508 ! A1T kernel(i+1) A2
8509         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8510          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8511          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8512 ! Following matrices are needed only for 6-th order cumulants
8513         IF (wcorr6.gt.0.0d0) THEN
8514         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8515          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8516          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8517         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8518          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8519          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8520          ADtEAderx(1,1,1,1,1,2))
8521         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8522          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8523          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8524          ADtEA1derx(1,1,1,1,1,2))
8525         ENDIF
8526 ! End 6-th order cumulants
8527         call transpose2(EUgder(1,1,l),auxmat(1,1))
8528         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8529         call transpose2(EUg(1,1,l),auxmat(1,1))
8530         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8531         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8532         do iii=1,2
8533           do kkk=1,5
8534             do lll=1,3
8535               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8536                 EAEAderx(1,1,lll,kkk,iii,2))
8537             enddo
8538           enddo
8539         enddo
8540 ! AEAb1 and AEAb2
8541 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8542 ! They are needed only when the fifth- or the sixth-order cumulants are
8543 ! indluded.
8544         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8545         call transpose2(AEA(1,1,1),auxmat(1,1))
8546         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8547         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8548         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8549         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8550         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8551         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8552         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8553         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8554         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8555         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8556         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8557         call transpose2(AEA(1,1,2),auxmat(1,1))
8558         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8559         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8560         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8561         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8562         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8563         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8564         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8565         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8566         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8567         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8568         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8569 ! Calculate the Cartesian derivatives of the vectors.
8570         do iii=1,2
8571           do kkk=1,5
8572             do lll=1,3
8573               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8574               call matvec2(auxmat(1,1),b1(1,iti),&
8575                 AEAb1derx(1,lll,kkk,iii,1,1))
8576               call matvec2(auxmat(1,1),Ub2(1,i),&
8577                 AEAb2derx(1,lll,kkk,iii,1,1))
8578               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8579                 AEAb1derx(1,lll,kkk,iii,2,1))
8580               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8581                 AEAb2derx(1,lll,kkk,iii,2,1))
8582               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8583               call matvec2(auxmat(1,1),b1(1,itj),&
8584                 AEAb1derx(1,lll,kkk,iii,1,2))
8585               call matvec2(auxmat(1,1),Ub2(1,j),&
8586                 AEAb2derx(1,lll,kkk,iii,1,2))
8587               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8588                 AEAb1derx(1,lll,kkk,iii,2,2))
8589               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8590                 AEAb2derx(1,lll,kkk,iii,2,2))
8591             enddo
8592           enddo
8593         enddo
8594         ENDIF
8595 ! End vectors
8596       else
8597 ! Antiparallel orientation of the two CA-CA-CA frames.
8598         if (i.gt.1) then
8599           iti=itortyp(itype(i,1))
8600         else
8601           iti=ntortyp+1
8602         endif
8603         itk1=itortyp(itype(k+1,1))
8604         itl=itortyp(itype(l,1))
8605         itj=itortyp(itype(j,1))
8606         if (j.lt.nres-1) then
8607           itj1=itortyp(itype(j+1,1))
8608         else
8609           itj1=ntortyp+1
8610         endif
8611 ! A2 kernel(j-1)T A1T
8612         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8613          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
8614          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8615 ! Following matrices are needed only for 6-th order cumulants
8616         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8617            j.eq.i+4 .and. l.eq.i+3)) THEN
8618         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8619          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8620          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8621         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8622          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8623          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8624          ADtEAderx(1,1,1,1,1,1))
8625         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8626          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8627          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8628          ADtEA1derx(1,1,1,1,1,1))
8629         ENDIF
8630 ! End 6-th order cumulants
8631         call transpose2(EUgder(1,1,k),auxmat(1,1))
8632         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8633         call transpose2(EUg(1,1,k),auxmat(1,1))
8634         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8635         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8636         do iii=1,2
8637           do kkk=1,5
8638             do lll=1,3
8639               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8640                 EAEAderx(1,1,lll,kkk,iii,1))
8641             enddo
8642           enddo
8643         enddo
8644 ! A2T kernel(i+1)T A1
8645         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8646          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
8647          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8648 ! Following matrices are needed only for 6-th order cumulants
8649         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8650            j.eq.i+4 .and. l.eq.i+3)) THEN
8651         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8652          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8653          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8654         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8655          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8656          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8657          ADtEAderx(1,1,1,1,1,2))
8658         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8659          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8660          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8661          ADtEA1derx(1,1,1,1,1,2))
8662         ENDIF
8663 ! End 6-th order cumulants
8664         call transpose2(EUgder(1,1,j),auxmat(1,1))
8665         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8666         call transpose2(EUg(1,1,j),auxmat(1,1))
8667         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8668         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8669         do iii=1,2
8670           do kkk=1,5
8671             do lll=1,3
8672               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8673                 EAEAderx(1,1,lll,kkk,iii,2))
8674             enddo
8675           enddo
8676         enddo
8677 ! AEAb1 and AEAb2
8678 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8679 ! They are needed only when the fifth- or the sixth-order cumulants are
8680 ! indluded.
8681         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8682           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8683         call transpose2(AEA(1,1,1),auxmat(1,1))
8684         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8685         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8686         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8687         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8688         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8689         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8690         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8691         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8692         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8693         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8694         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8695         call transpose2(AEA(1,1,2),auxmat(1,1))
8696         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8697         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8698         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8699         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8700         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8701         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8702         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8703         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8704         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8705         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8706         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8707 ! Calculate the Cartesian derivatives of the vectors.
8708         do iii=1,2
8709           do kkk=1,5
8710             do lll=1,3
8711               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8712               call matvec2(auxmat(1,1),b1(1,iti),&
8713                 AEAb1derx(1,lll,kkk,iii,1,1))
8714               call matvec2(auxmat(1,1),Ub2(1,i),&
8715                 AEAb2derx(1,lll,kkk,iii,1,1))
8716               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8717                 AEAb1derx(1,lll,kkk,iii,2,1))
8718               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8719                 AEAb2derx(1,lll,kkk,iii,2,1))
8720               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8721               call matvec2(auxmat(1,1),b1(1,itl),&
8722                 AEAb1derx(1,lll,kkk,iii,1,2))
8723               call matvec2(auxmat(1,1),Ub2(1,l),&
8724                 AEAb2derx(1,lll,kkk,iii,1,2))
8725               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8726                 AEAb1derx(1,lll,kkk,iii,2,2))
8727               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8728                 AEAb2derx(1,lll,kkk,iii,2,2))
8729             enddo
8730           enddo
8731         enddo
8732         ENDIF
8733 ! End vectors
8734       endif
8735       return
8736       end subroutine calc_eello
8737 !-----------------------------------------------------------------------------
8738       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8739       use comm_kut
8740       implicit none
8741       integer :: nderg
8742       logical :: transp
8743       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8744       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8745       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8746       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8747       integer :: iii,kkk,lll
8748       integer :: jjj,mmm
8749 !el      logical :: lprn
8750 !el      common /kutas/ lprn
8751       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8752       do iii=1,nderg
8753         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8754           AKAderg(1,1,iii))
8755       enddo
8756 !d      if (lprn) write (2,*) 'In kernel'
8757       do kkk=1,5
8758 !d        if (lprn) write (2,*) 'kkk=',kkk
8759         do lll=1,3
8760           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8761             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8762 !d          if (lprn) then
8763 !d            write (2,*) 'lll=',lll
8764 !d            write (2,*) 'iii=1'
8765 !d            do jjj=1,2
8766 !d              write (2,'(3(2f10.5),5x)')
8767 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8768 !d            enddo
8769 !d          endif
8770           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8771             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8772 !d          if (lprn) then
8773 !d            write (2,*) 'lll=',lll
8774 !d            write (2,*) 'iii=2'
8775 !d            do jjj=1,2
8776 !d              write (2,'(3(2f10.5),5x)')
8777 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8778 !d            enddo
8779 !d          endif
8780         enddo
8781       enddo
8782       return
8783       end subroutine kernel
8784 !-----------------------------------------------------------------------------
8785       real(kind=8) function eello4(i,j,k,l,jj,kk)
8786 !      implicit real*8 (a-h,o-z)
8787 !      include 'DIMENSIONS'
8788 !      include 'COMMON.IOUNITS'
8789 !      include 'COMMON.CHAIN'
8790 !      include 'COMMON.DERIV'
8791 !      include 'COMMON.INTERACT'
8792 !      include 'COMMON.CONTACTS'
8793 !      include 'COMMON.TORSION'
8794 !      include 'COMMON.VAR'
8795 !      include 'COMMON.GEO'
8796       real(kind=8),dimension(2,2) :: pizda
8797       real(kind=8),dimension(3) :: ggg1,ggg2
8798       real(kind=8) ::  eel4,glongij,glongkl
8799       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8800 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8801 !d        eello4=0.0d0
8802 !d        return
8803 !d      endif
8804 !d      print *,'eello4:',i,j,k,l,jj,kk
8805 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8806 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8807 !old      eij=facont_hb(jj,i)
8808 !old      ekl=facont_hb(kk,k)
8809 !old      ekont=eij*ekl
8810       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8811 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8812       gcorr_loc(k-1)=gcorr_loc(k-1) &
8813          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8814       if (l.eq.j+1) then
8815         gcorr_loc(l-1)=gcorr_loc(l-1) &
8816            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8817       else
8818         gcorr_loc(j-1)=gcorr_loc(j-1) &
8819            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8820       endif
8821       do iii=1,2
8822         do kkk=1,5
8823           do lll=1,3
8824             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8825                               -EAEAderx(2,2,lll,kkk,iii,1)
8826 !d            derx(lll,kkk,iii)=0.0d0
8827           enddo
8828         enddo
8829       enddo
8830 !d      gcorr_loc(l-1)=0.0d0
8831 !d      gcorr_loc(j-1)=0.0d0
8832 !d      gcorr_loc(k-1)=0.0d0
8833 !d      eel4=1.0d0
8834 !d      write (iout,*)'Contacts have occurred for peptide groups',
8835 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8836 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8837       if (j.lt.nres-1) then
8838         j1=j+1
8839         j2=j-1
8840       else
8841         j1=j-1
8842         j2=j-2
8843       endif
8844       if (l.lt.nres-1) then
8845         l1=l+1
8846         l2=l-1
8847       else
8848         l1=l-1
8849         l2=l-2
8850       endif
8851       do ll=1,3
8852 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8853 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8854         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8855         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8856 !grad        ghalf=0.5d0*ggg1(ll)
8857         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8858         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8859         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8860         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8861         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8862         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8863 !grad        ghalf=0.5d0*ggg2(ll)
8864         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8865         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8866         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8867         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8868         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8869         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8870       enddo
8871 !grad      do m=i+1,j-1
8872 !grad        do ll=1,3
8873 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8874 !grad        enddo
8875 !grad      enddo
8876 !grad      do m=k+1,l-1
8877 !grad        do ll=1,3
8878 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8879 !grad        enddo
8880 !grad      enddo
8881 !grad      do m=i+2,j2
8882 !grad        do ll=1,3
8883 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8884 !grad        enddo
8885 !grad      enddo
8886 !grad      do m=k+2,l2
8887 !grad        do ll=1,3
8888 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8889 !grad        enddo
8890 !grad      enddo
8891 !d      do iii=1,nres-3
8892 !d        write (2,*) iii,gcorr_loc(iii)
8893 !d      enddo
8894       eello4=ekont*eel4
8895 !d      write (2,*) 'ekont',ekont
8896 !d      write (iout,*) 'eello4',ekont*eel4
8897       return
8898       end function eello4
8899 !-----------------------------------------------------------------------------
8900       real(kind=8) function eello5(i,j,k,l,jj,kk)
8901 !      implicit real*8 (a-h,o-z)
8902 !      include 'DIMENSIONS'
8903 !      include 'COMMON.IOUNITS'
8904 !      include 'COMMON.CHAIN'
8905 !      include 'COMMON.DERIV'
8906 !      include 'COMMON.INTERACT'
8907 !      include 'COMMON.CONTACTS'
8908 !      include 'COMMON.TORSION'
8909 !      include 'COMMON.VAR'
8910 !      include 'COMMON.GEO'
8911       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8912       real(kind=8),dimension(2) :: vv
8913       real(kind=8),dimension(3) :: ggg1,ggg2
8914       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8915       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8916       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8917 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8918 !                                                                              C
8919 !                            Parallel chains                                   C
8920 !                                                                              C
8921 !          o             o                   o             o                   C
8922 !         /l\           / \             \   / \           / \   /              C
8923 !        /   \         /   \             \ /   \         /   \ /               C
8924 !       j| o |l1       | o |                o| o |         | o |o                C
8925 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8926 !      \i/   \         /   \ /             /   \         /   \                 C
8927 !       o    k1             o                                                  C
8928 !         (I)          (II)                (III)          (IV)                 C
8929 !                                                                              C
8930 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8931 !                                                                              C
8932 !                            Antiparallel chains                               C
8933 !                                                                              C
8934 !          o             o                   o             o                   C
8935 !         /j\           / \             \   / \           / \   /              C
8936 !        /   \         /   \             \ /   \         /   \ /               C
8937 !      j1| o |l        | o |                o| o |         | o |o                C
8938 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8939 !      \i/   \         /   \ /             /   \         /   \                 C
8940 !       o     k1            o                                                  C
8941 !         (I)          (II)                (III)          (IV)                 C
8942 !                                                                              C
8943 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8944 !                                                                              C
8945 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
8946 !                                                                              C
8947 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8948 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8949 !d        eello5=0.0d0
8950 !d        return
8951 !d      endif
8952 !d      write (iout,*)
8953 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8954 !d     &   ' and',k,l
8955       itk=itortyp(itype(k,1))
8956       itl=itortyp(itype(l,1))
8957       itj=itortyp(itype(j,1))
8958       eello5_1=0.0d0
8959       eello5_2=0.0d0
8960       eello5_3=0.0d0
8961       eello5_4=0.0d0
8962 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8963 !d     &   eel5_3_num,eel5_4_num)
8964       do iii=1,2
8965         do kkk=1,5
8966           do lll=1,3
8967             derx(lll,kkk,iii)=0.0d0
8968           enddo
8969         enddo
8970       enddo
8971 !d      eij=facont_hb(jj,i)
8972 !d      ekl=facont_hb(kk,k)
8973 !d      ekont=eij*ekl
8974 !d      write (iout,*)'Contacts have occurred for peptide groups',
8975 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
8976 !d      goto 1111
8977 ! Contribution from the graph I.
8978 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8979 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8980       call transpose2(EUg(1,1,k),auxmat(1,1))
8981       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8982       vv(1)=pizda(1,1)-pizda(2,2)
8983       vv(2)=pizda(1,2)+pizda(2,1)
8984       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
8985        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8986 ! Explicit gradient in virtual-dihedral angles.
8987       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
8988        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
8989        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8990       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8991       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8992       vv(1)=pizda(1,1)-pizda(2,2)
8993       vv(2)=pizda(1,2)+pizda(2,1)
8994       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8995        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
8996        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8997       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8998       vv(1)=pizda(1,1)-pizda(2,2)
8999       vv(2)=pizda(1,2)+pizda(2,1)
9000       if (l.eq.j+1) then
9001         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9002          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9003          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9004       else
9005         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9006          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9007          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9008       endif
9009 ! Cartesian gradient
9010       do iii=1,2
9011         do kkk=1,5
9012           do lll=1,3
9013             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9014               pizda(1,1))
9015             vv(1)=pizda(1,1)-pizda(2,2)
9016             vv(2)=pizda(1,2)+pizda(2,1)
9017             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9018              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
9019              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9020           enddo
9021         enddo
9022       enddo
9023 !      goto 1112
9024 !1111  continue
9025 ! Contribution from graph II
9026       call transpose2(EE(1,1,itk),auxmat(1,1))
9027       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9028       vv(1)=pizda(1,1)+pizda(2,2)
9029       vv(2)=pizda(2,1)-pizda(1,2)
9030       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
9031        -0.5d0*scalar2(vv(1),Ctobr(1,k))
9032 ! Explicit gradient in virtual-dihedral angles.
9033       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9034        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9035       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9036       vv(1)=pizda(1,1)+pizda(2,2)
9037       vv(2)=pizda(2,1)-pizda(1,2)
9038       if (l.eq.j+1) then
9039         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9040          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9041          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9042       else
9043         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9044          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9045          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9046       endif
9047 ! Cartesian gradient
9048       do iii=1,2
9049         do kkk=1,5
9050           do lll=1,3
9051             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9052               pizda(1,1))
9053             vv(1)=pizda(1,1)+pizda(2,2)
9054             vv(2)=pizda(2,1)-pizda(1,2)
9055             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9056              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
9057              -0.5d0*scalar2(vv(1),Ctobr(1,k))
9058           enddo
9059         enddo
9060       enddo
9061 !d      goto 1112
9062 !d1111  continue
9063       if (l.eq.j+1) then
9064 !d        goto 1110
9065 ! Parallel orientation
9066 ! Contribution from graph III
9067         call transpose2(EUg(1,1,l),auxmat(1,1))
9068         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9069         vv(1)=pizda(1,1)-pizda(2,2)
9070         vv(2)=pizda(1,2)+pizda(2,1)
9071         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
9072          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9073 ! Explicit gradient in virtual-dihedral angles.
9074         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9075          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
9076          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9077         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9078         vv(1)=pizda(1,1)-pizda(2,2)
9079         vv(2)=pizda(1,2)+pizda(2,1)
9080         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9081          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
9082          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9083         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9084         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9085         vv(1)=pizda(1,1)-pizda(2,2)
9086         vv(2)=pizda(1,2)+pizda(2,1)
9087         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9088          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
9089          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9090 ! Cartesian gradient
9091         do iii=1,2
9092           do kkk=1,5
9093             do lll=1,3
9094               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9095                 pizda(1,1))
9096               vv(1)=pizda(1,1)-pizda(2,2)
9097               vv(2)=pizda(1,2)+pizda(2,1)
9098               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9099                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
9100                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9101             enddo
9102           enddo
9103         enddo
9104 !d        goto 1112
9105 ! Contribution from graph IV
9106 !d1110    continue
9107         call transpose2(EE(1,1,itl),auxmat(1,1))
9108         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9109         vv(1)=pizda(1,1)+pizda(2,2)
9110         vv(2)=pizda(2,1)-pizda(1,2)
9111         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
9112          -0.5d0*scalar2(vv(1),Ctobr(1,l))
9113 ! Explicit gradient in virtual-dihedral angles.
9114         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9115          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9116         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9117         vv(1)=pizda(1,1)+pizda(2,2)
9118         vv(2)=pizda(2,1)-pizda(1,2)
9119         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9120          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
9121          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9122 ! Cartesian gradient
9123         do iii=1,2
9124           do kkk=1,5
9125             do lll=1,3
9126               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9127                 pizda(1,1))
9128               vv(1)=pizda(1,1)+pizda(2,2)
9129               vv(2)=pizda(2,1)-pizda(1,2)
9130               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9131                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
9132                -0.5d0*scalar2(vv(1),Ctobr(1,l))
9133             enddo
9134           enddo
9135         enddo
9136       else
9137 ! Antiparallel orientation
9138 ! Contribution from graph III
9139 !        goto 1110
9140         call transpose2(EUg(1,1,j),auxmat(1,1))
9141         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9142         vv(1)=pizda(1,1)-pizda(2,2)
9143         vv(2)=pizda(1,2)+pizda(2,1)
9144         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
9145          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9146 ! Explicit gradient in virtual-dihedral angles.
9147         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9148          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
9149          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9150         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9151         vv(1)=pizda(1,1)-pizda(2,2)
9152         vv(2)=pizda(1,2)+pizda(2,1)
9153         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9154          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
9155          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9156         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9157         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9158         vv(1)=pizda(1,1)-pizda(2,2)
9159         vv(2)=pizda(1,2)+pizda(2,1)
9160         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9161          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
9162          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9163 ! Cartesian gradient
9164         do iii=1,2
9165           do kkk=1,5
9166             do lll=1,3
9167               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9168                 pizda(1,1))
9169               vv(1)=pizda(1,1)-pizda(2,2)
9170               vv(2)=pizda(1,2)+pizda(2,1)
9171               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9172                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9173                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9174             enddo
9175           enddo
9176         enddo
9177 !d        goto 1112
9178 ! Contribution from graph IV
9179 1110    continue
9180         call transpose2(EE(1,1,itj),auxmat(1,1))
9181         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9182         vv(1)=pizda(1,1)+pizda(2,2)
9183         vv(2)=pizda(2,1)-pizda(1,2)
9184         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9185          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9186 ! Explicit gradient in virtual-dihedral angles.
9187         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9188          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9189         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9190         vv(1)=pizda(1,1)+pizda(2,2)
9191         vv(2)=pizda(2,1)-pizda(1,2)
9192         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9193          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9194          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9195 ! Cartesian gradient
9196         do iii=1,2
9197           do kkk=1,5
9198             do lll=1,3
9199               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9200                 pizda(1,1))
9201               vv(1)=pizda(1,1)+pizda(2,2)
9202               vv(2)=pizda(2,1)-pizda(1,2)
9203               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9204                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9205                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9206             enddo
9207           enddo
9208         enddo
9209       endif
9210 1112  continue
9211       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9212 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9213 !d        write (2,*) 'ijkl',i,j,k,l
9214 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9215 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9216 !d      endif
9217 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9218 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9219 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9220 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9221       if (j.lt.nres-1) then
9222         j1=j+1
9223         j2=j-1
9224       else
9225         j1=j-1
9226         j2=j-2
9227       endif
9228       if (l.lt.nres-1) then
9229         l1=l+1
9230         l2=l-1
9231       else
9232         l1=l-1
9233         l2=l-2
9234       endif
9235 !d      eij=1.0d0
9236 !d      ekl=1.0d0
9237 !d      ekont=1.0d0
9238 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9239 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9240 !        summed up outside the subrouine as for the other subroutines
9241 !        handling long-range interactions. The old code is commented out
9242 !        with "cgrad" to keep track of changes.
9243       do ll=1,3
9244 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9245 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9246         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9247         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9248 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9249 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9250 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9251 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9252 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9253 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9254 !     &   gradcorr5ij,
9255 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9256 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9257 !grad        ghalf=0.5d0*ggg1(ll)
9258 !d        ghalf=0.0d0
9259         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9260         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9261         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9262         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9263         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9264         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9265 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9266 !grad        ghalf=0.5d0*ggg2(ll)
9267         ghalf=0.0d0
9268         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9269         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9270         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9271         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9272         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9273         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9274       enddo
9275 !d      goto 1112
9276 !grad      do m=i+1,j-1
9277 !grad        do ll=1,3
9278 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9279 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9280 !grad        enddo
9281 !grad      enddo
9282 !grad      do m=k+1,l-1
9283 !grad        do ll=1,3
9284 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9285 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9286 !grad        enddo
9287 !grad      enddo
9288 !1112  continue
9289 !grad      do m=i+2,j2
9290 !grad        do ll=1,3
9291 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9292 !grad        enddo
9293 !grad      enddo
9294 !grad      do m=k+2,l2
9295 !grad        do ll=1,3
9296 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9297 !grad        enddo
9298 !grad      enddo
9299 !d      do iii=1,nres-3
9300 !d        write (2,*) iii,g_corr5_loc(iii)
9301 !d      enddo
9302       eello5=ekont*eel5
9303 !d      write (2,*) 'ekont',ekont
9304 !d      write (iout,*) 'eello5',ekont*eel5
9305       return
9306       end function eello5
9307 !-----------------------------------------------------------------------------
9308       real(kind=8) function eello6(i,j,k,l,jj,kk)
9309 !      implicit real*8 (a-h,o-z)
9310 !      include 'DIMENSIONS'
9311 !      include 'COMMON.IOUNITS'
9312 !      include 'COMMON.CHAIN'
9313 !      include 'COMMON.DERIV'
9314 !      include 'COMMON.INTERACT'
9315 !      include 'COMMON.CONTACTS'
9316 !      include 'COMMON.TORSION'
9317 !      include 'COMMON.VAR'
9318 !      include 'COMMON.GEO'
9319 !      include 'COMMON.FFIELD'
9320       real(kind=8),dimension(3) :: ggg1,ggg2
9321       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9322                    eello6_6,eel6
9323       real(kind=8) :: gradcorr6ij,gradcorr6kl
9324       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9325 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9326 !d        eello6=0.0d0
9327 !d        return
9328 !d      endif
9329 !d      write (iout,*)
9330 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9331 !d     &   ' and',k,l
9332       eello6_1=0.0d0
9333       eello6_2=0.0d0
9334       eello6_3=0.0d0
9335       eello6_4=0.0d0
9336       eello6_5=0.0d0
9337       eello6_6=0.0d0
9338 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9339 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9340       do iii=1,2
9341         do kkk=1,5
9342           do lll=1,3
9343             derx(lll,kkk,iii)=0.0d0
9344           enddo
9345         enddo
9346       enddo
9347 !d      eij=facont_hb(jj,i)
9348 !d      ekl=facont_hb(kk,k)
9349 !d      ekont=eij*ekl
9350 !d      eij=1.0d0
9351 !d      ekl=1.0d0
9352 !d      ekont=1.0d0
9353       if (l.eq.j+1) then
9354         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9355         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9356         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9357         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9358         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9359         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9360       else
9361         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9362         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9363         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9364         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9365         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9366           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9367         else
9368           eello6_5=0.0d0
9369         endif
9370         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9371       endif
9372 ! If turn contributions are considered, they will be handled separately.
9373       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9374 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9375 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9376 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9377 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9378 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9379 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9380 !d      goto 1112
9381       if (j.lt.nres-1) then
9382         j1=j+1
9383         j2=j-1
9384       else
9385         j1=j-1
9386         j2=j-2
9387       endif
9388       if (l.lt.nres-1) then
9389         l1=l+1
9390         l2=l-1
9391       else
9392         l1=l-1
9393         l2=l-2
9394       endif
9395       do ll=1,3
9396 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9397 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9398 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9399 !grad        ghalf=0.5d0*ggg1(ll)
9400 !d        ghalf=0.0d0
9401         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9402         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9403         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9404         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9405         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9406         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9407         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9408         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9409 !grad        ghalf=0.5d0*ggg2(ll)
9410 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9411 !d        ghalf=0.0d0
9412         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9413         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9414         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9415         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9416         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9417         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9418       enddo
9419 !d      goto 1112
9420 !grad      do m=i+1,j-1
9421 !grad        do ll=1,3
9422 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9423 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9424 !grad        enddo
9425 !grad      enddo
9426 !grad      do m=k+1,l-1
9427 !grad        do ll=1,3
9428 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9429 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9430 !grad        enddo
9431 !grad      enddo
9432 !grad1112  continue
9433 !grad      do m=i+2,j2
9434 !grad        do ll=1,3
9435 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9436 !grad        enddo
9437 !grad      enddo
9438 !grad      do m=k+2,l2
9439 !grad        do ll=1,3
9440 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9441 !grad        enddo
9442 !grad      enddo
9443 !d      do iii=1,nres-3
9444 !d        write (2,*) iii,g_corr6_loc(iii)
9445 !d      enddo
9446       eello6=ekont*eel6
9447 !d      write (2,*) 'ekont',ekont
9448 !d      write (iout,*) 'eello6',ekont*eel6
9449       return
9450       end function eello6
9451 !-----------------------------------------------------------------------------
9452       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9453       use comm_kut
9454 !      implicit real*8 (a-h,o-z)
9455 !      include 'DIMENSIONS'
9456 !      include 'COMMON.IOUNITS'
9457 !      include 'COMMON.CHAIN'
9458 !      include 'COMMON.DERIV'
9459 !      include 'COMMON.INTERACT'
9460 !      include 'COMMON.CONTACTS'
9461 !      include 'COMMON.TORSION'
9462 !      include 'COMMON.VAR'
9463 !      include 'COMMON.GEO'
9464       real(kind=8),dimension(2) :: vv,vv1
9465       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9466       logical :: swap
9467 !el      logical :: lprn
9468 !el      common /kutas/ lprn
9469       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9470       real(kind=8) :: s1,s2,s3,s4,s5
9471 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9472 !                                                                              C
9473 !      Parallel       Antiparallel                                             C
9474 !                                                                              C
9475 !          o             o                                                     C
9476 !         /l\           /j\                                                    C
9477 !        /   \         /   \                                                   C
9478 !       /| o |         | o |\                                                  C
9479 !     \ j|/k\|  /   \  |/k\|l /                                                C
9480 !      \ /   \ /     \ /   \ /                                                 C
9481 !       o     o       o     o                                                  C
9482 !       i             i                                                        C
9483 !                                                                              C
9484 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9485       itk=itortyp(itype(k,1))
9486       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9487       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9488       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9489       call transpose2(EUgC(1,1,k),auxmat(1,1))
9490       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9491       vv1(1)=pizda1(1,1)-pizda1(2,2)
9492       vv1(2)=pizda1(1,2)+pizda1(2,1)
9493       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9494       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9495       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9496       s5=scalar2(vv(1),Dtobr2(1,i))
9497 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9498       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9499       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9500        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9501        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9502        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9503        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9504        +scalar2(vv(1),Dtobr2der(1,i)))
9505       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9506       vv1(1)=pizda1(1,1)-pizda1(2,2)
9507       vv1(2)=pizda1(1,2)+pizda1(2,1)
9508       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9509       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9510       if (l.eq.j+1) then
9511         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9512        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9513        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9514        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9515        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9516       else
9517         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9518        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9519        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9520        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9521        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9522       endif
9523       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9524       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9525       vv1(1)=pizda1(1,1)-pizda1(2,2)
9526       vv1(2)=pizda1(1,2)+pizda1(2,1)
9527       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9528        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9529        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9530        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9531       do iii=1,2
9532         if (swap) then
9533           ind=3-iii
9534         else
9535           ind=iii
9536         endif
9537         do kkk=1,5
9538           do lll=1,3
9539             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9540             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9541             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9542             call transpose2(EUgC(1,1,k),auxmat(1,1))
9543             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9544               pizda1(1,1))
9545             vv1(1)=pizda1(1,1)-pizda1(2,2)
9546             vv1(2)=pizda1(1,2)+pizda1(2,1)
9547             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9548             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
9549              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9550             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
9551              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9552             s5=scalar2(vv(1),Dtobr2(1,i))
9553             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9554           enddo
9555         enddo
9556       enddo
9557       return
9558       end function eello6_graph1
9559 !-----------------------------------------------------------------------------
9560       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
9561       use comm_kut
9562 !      implicit real*8 (a-h,o-z)
9563 !      include 'DIMENSIONS'
9564 !      include 'COMMON.IOUNITS'
9565 !      include 'COMMON.CHAIN'
9566 !      include 'COMMON.DERIV'
9567 !      include 'COMMON.INTERACT'
9568 !      include 'COMMON.CONTACTS'
9569 !      include 'COMMON.TORSION'
9570 !      include 'COMMON.VAR'
9571 !      include 'COMMON.GEO'
9572       logical :: swap
9573       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
9574       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9575 !el      logical :: lprn
9576 !el      common /kutas/ lprn
9577       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
9578       real(kind=8) :: s2,s3,s4
9579 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9580 !                                                                              C
9581 !      Parallel       Antiparallel                                             C
9582 !                                                                              C
9583 !          o             o                                                     C
9584 !     \   /l\           /j\   /                                                C
9585 !      \ /   \         /   \ /                                                 C
9586 !       o| o |         | o |o                                                  C
9587 !     \ j|/k\|      \  |/k\|l                                                  C
9588 !      \ /   \       \ /   \                                                   C
9589 !       o             o                                                        C
9590 !       i             i                                                        C
9591 !                                                                              C
9592 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9593 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9594 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9595 !           but not in a cluster cumulant
9596 #ifdef MOMENT
9597       s1=dip(1,jj,i)*dip(1,kk,k)
9598 #endif
9599       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9600       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9601       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9602       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9603       call transpose2(EUg(1,1,k),auxmat(1,1))
9604       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9605       vv(1)=pizda(1,1)-pizda(2,2)
9606       vv(2)=pizda(1,2)+pizda(2,1)
9607       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9608 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9609 #ifdef MOMENT
9610       eello6_graph2=-(s1+s2+s3+s4)
9611 #else
9612       eello6_graph2=-(s2+s3+s4)
9613 #endif
9614 !      eello6_graph2=-s3
9615 ! Derivatives in gamma(i-1)
9616       if (i.gt.1) then
9617 #ifdef MOMENT
9618         s1=dipderg(1,jj,i)*dip(1,kk,k)
9619 #endif
9620         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9621         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9622         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9623         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9624 #ifdef MOMENT
9625         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9626 #else
9627         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9628 #endif
9629 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9630       endif
9631 ! Derivatives in gamma(k-1)
9632 #ifdef MOMENT
9633       s1=dip(1,jj,i)*dipderg(1,kk,k)
9634 #endif
9635       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9636       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9637       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9638       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9639       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9640       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9641       vv(1)=pizda(1,1)-pizda(2,2)
9642       vv(2)=pizda(1,2)+pizda(2,1)
9643       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9644 #ifdef MOMENT
9645       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9646 #else
9647       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9648 #endif
9649 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9650 ! Derivatives in gamma(j-1) or gamma(l-1)
9651       if (j.gt.1) then
9652 #ifdef MOMENT
9653         s1=dipderg(3,jj,i)*dip(1,kk,k)
9654 #endif
9655         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9656         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9657         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9658         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9659         vv(1)=pizda(1,1)-pizda(2,2)
9660         vv(2)=pizda(1,2)+pizda(2,1)
9661         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9662 #ifdef MOMENT
9663         if (swap) then
9664           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9665         else
9666           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9667         endif
9668 #endif
9669         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9670 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9671       endif
9672 ! Derivatives in gamma(l-1) or gamma(j-1)
9673       if (l.gt.1) then
9674 #ifdef MOMENT
9675         s1=dip(1,jj,i)*dipderg(3,kk,k)
9676 #endif
9677         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9678         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9679         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9680         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9681         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9682         vv(1)=pizda(1,1)-pizda(2,2)
9683         vv(2)=pizda(1,2)+pizda(2,1)
9684         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9685 #ifdef MOMENT
9686         if (swap) then
9687           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9688         else
9689           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9690         endif
9691 #endif
9692         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9693 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9694       endif
9695 ! Cartesian derivatives.
9696       if (lprn) then
9697         write (2,*) 'In eello6_graph2'
9698         do iii=1,2
9699           write (2,*) 'iii=',iii
9700           do kkk=1,5
9701             write (2,*) 'kkk=',kkk
9702             do jjj=1,2
9703               write (2,'(3(2f10.5),5x)') &
9704               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9705             enddo
9706           enddo
9707         enddo
9708       endif
9709       do iii=1,2
9710         do kkk=1,5
9711           do lll=1,3
9712 #ifdef MOMENT
9713             if (iii.eq.1) then
9714               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9715             else
9716               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9717             endif
9718 #endif
9719             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9720               auxvec(1))
9721             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9722             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9723               auxvec(1))
9724             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9725             call transpose2(EUg(1,1,k),auxmat(1,1))
9726             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9727               pizda(1,1))
9728             vv(1)=pizda(1,1)-pizda(2,2)
9729             vv(2)=pizda(1,2)+pizda(2,1)
9730             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9731 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9732 #ifdef MOMENT
9733             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9734 #else
9735             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9736 #endif
9737             if (swap) then
9738               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9739             else
9740               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9741             endif
9742           enddo
9743         enddo
9744       enddo
9745       return
9746       end function eello6_graph2
9747 !-----------------------------------------------------------------------------
9748       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9749 !      implicit real*8 (a-h,o-z)
9750 !      include 'DIMENSIONS'
9751 !      include 'COMMON.IOUNITS'
9752 !      include 'COMMON.CHAIN'
9753 !      include 'COMMON.DERIV'
9754 !      include 'COMMON.INTERACT'
9755 !      include 'COMMON.CONTACTS'
9756 !      include 'COMMON.TORSION'
9757 !      include 'COMMON.VAR'
9758 !      include 'COMMON.GEO'
9759       real(kind=8),dimension(2) :: vv,auxvec
9760       real(kind=8),dimension(2,2) :: pizda,auxmat
9761       logical :: swap
9762       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9763       real(kind=8) :: s1,s2,s3,s4
9764 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9765 !                                                                              C
9766 !      Parallel       Antiparallel                                             C
9767 !                                                                              C
9768 !          o             o                                                     C
9769 !         /l\   /   \   /j\                                                    C
9770 !        /   \ /     \ /   \                                                   C
9771 !       /| o |o       o| o |\                                                  C
9772 !       j|/k\|  /      |/k\|l /                                                C
9773 !        /   \ /       /   \ /                                                 C
9774 !       /     o       /     o                                                  C
9775 !       i             i                                                        C
9776 !                                                                              C
9777 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9778 !
9779 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9780 !           energy moment and not to the cluster cumulant.
9781       iti=itortyp(itype(i,1))
9782       if (j.lt.nres-1) then
9783         itj1=itortyp(itype(j+1,1))
9784       else
9785         itj1=ntortyp+1
9786       endif
9787       itk=itortyp(itype(k,1))
9788       itk1=itortyp(itype(k+1,1))
9789       if (l.lt.nres-1) then
9790         itl1=itortyp(itype(l+1,1))
9791       else
9792         itl1=ntortyp+1
9793       endif
9794 #ifdef MOMENT
9795       s1=dip(4,jj,i)*dip(4,kk,k)
9796 #endif
9797       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9798       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9799       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9800       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9801       call transpose2(EE(1,1,itk),auxmat(1,1))
9802       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9803       vv(1)=pizda(1,1)+pizda(2,2)
9804       vv(2)=pizda(2,1)-pizda(1,2)
9805       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9806 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9807 !d     & "sum",-(s2+s3+s4)
9808 #ifdef MOMENT
9809       eello6_graph3=-(s1+s2+s3+s4)
9810 #else
9811       eello6_graph3=-(s2+s3+s4)
9812 #endif
9813 !      eello6_graph3=-s4
9814 ! Derivatives in gamma(k-1)
9815       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9816       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9817       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9818       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9819 ! Derivatives in gamma(l-1)
9820       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9821       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9822       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9823       vv(1)=pizda(1,1)+pizda(2,2)
9824       vv(2)=pizda(2,1)-pizda(1,2)
9825       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9826       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9827 ! Cartesian derivatives.
9828       do iii=1,2
9829         do kkk=1,5
9830           do lll=1,3
9831 #ifdef MOMENT
9832             if (iii.eq.1) then
9833               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9834             else
9835               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9836             endif
9837 #endif
9838             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9839               auxvec(1))
9840             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9841             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9842               auxvec(1))
9843             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9844             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9845               pizda(1,1))
9846             vv(1)=pizda(1,1)+pizda(2,2)
9847             vv(2)=pizda(2,1)-pizda(1,2)
9848             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9849 #ifdef MOMENT
9850             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9851 #else
9852             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9853 #endif
9854             if (swap) then
9855               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9856             else
9857               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9858             endif
9859 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9860           enddo
9861         enddo
9862       enddo
9863       return
9864       end function eello6_graph3
9865 !-----------------------------------------------------------------------------
9866       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9867 !      implicit real*8 (a-h,o-z)
9868 !      include 'DIMENSIONS'
9869 !      include 'COMMON.IOUNITS'
9870 !      include 'COMMON.CHAIN'
9871 !      include 'COMMON.DERIV'
9872 !      include 'COMMON.INTERACT'
9873 !      include 'COMMON.CONTACTS'
9874 !      include 'COMMON.TORSION'
9875 !      include 'COMMON.VAR'
9876 !      include 'COMMON.GEO'
9877 !      include 'COMMON.FFIELD'
9878       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9879       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9880       logical :: swap
9881       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9882               iii,kkk,lll
9883       real(kind=8) :: s1,s2,s3,s4
9884 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9885 !                                                                              C
9886 !      Parallel       Antiparallel                                             C
9887 !                                                                              C
9888 !          o             o                                                     C
9889 !         /l\   /   \   /j\                                                    C
9890 !        /   \ /     \ /   \                                                   C
9891 !       /| o |o       o| o |\                                                  C
9892 !     \ j|/k\|      \  |/k\|l                                                  C
9893 !      \ /   \       \ /   \                                                   C
9894 !       o     \       o     \                                                  C
9895 !       i             i                                                        C
9896 !                                                                              C
9897 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9898 !
9899 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9900 !           energy moment and not to the cluster cumulant.
9901 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9902       iti=itortyp(itype(i,1))
9903       itj=itortyp(itype(j,1))
9904       if (j.lt.nres-1) then
9905         itj1=itortyp(itype(j+1,1))
9906       else
9907         itj1=ntortyp+1
9908       endif
9909       itk=itortyp(itype(k,1))
9910       if (k.lt.nres-1) then
9911         itk1=itortyp(itype(k+1,1))
9912       else
9913         itk1=ntortyp+1
9914       endif
9915       itl=itortyp(itype(l,1))
9916       if (l.lt.nres-1) then
9917         itl1=itortyp(itype(l+1,1))
9918       else
9919         itl1=ntortyp+1
9920       endif
9921 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9922 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9923 !d     & ' itl',itl,' itl1',itl1
9924 #ifdef MOMENT
9925       if (imat.eq.1) then
9926         s1=dip(3,jj,i)*dip(3,kk,k)
9927       else
9928         s1=dip(2,jj,j)*dip(2,kk,l)
9929       endif
9930 #endif
9931       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9932       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9933       if (j.eq.l+1) then
9934         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9935         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9936       else
9937         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9938         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9939       endif
9940       call transpose2(EUg(1,1,k),auxmat(1,1))
9941       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9942       vv(1)=pizda(1,1)-pizda(2,2)
9943       vv(2)=pizda(2,1)+pizda(1,2)
9944       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9945 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9946 #ifdef MOMENT
9947       eello6_graph4=-(s1+s2+s3+s4)
9948 #else
9949       eello6_graph4=-(s2+s3+s4)
9950 #endif
9951 ! Derivatives in gamma(i-1)
9952       if (i.gt.1) then
9953 #ifdef MOMENT
9954         if (imat.eq.1) then
9955           s1=dipderg(2,jj,i)*dip(3,kk,k)
9956         else
9957           s1=dipderg(4,jj,j)*dip(2,kk,l)
9958         endif
9959 #endif
9960         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9961         if (j.eq.l+1) then
9962           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9963           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9964         else
9965           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9966           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9967         endif
9968         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9969         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9970 !d          write (2,*) 'turn6 derivatives'
9971 #ifdef MOMENT
9972           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9973 #else
9974           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9975 #endif
9976         else
9977 #ifdef MOMENT
9978           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9979 #else
9980           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9981 #endif
9982         endif
9983       endif
9984 ! Derivatives in gamma(k-1)
9985 #ifdef MOMENT
9986       if (imat.eq.1) then
9987         s1=dip(3,jj,i)*dipderg(2,kk,k)
9988       else
9989         s1=dip(2,jj,j)*dipderg(4,kk,l)
9990       endif
9991 #endif
9992       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9993       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9994       if (j.eq.l+1) then
9995         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9996         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9997       else
9998         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9999         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10000       endif
10001       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10002       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10003       vv(1)=pizda(1,1)-pizda(2,2)
10004       vv(2)=pizda(2,1)+pizda(1,2)
10005       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10006       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10007 #ifdef MOMENT
10008         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10009 #else
10010         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10011 #endif
10012       else
10013 #ifdef MOMENT
10014         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10015 #else
10016         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10017 #endif
10018       endif
10019 ! Derivatives in gamma(j-1) or gamma(l-1)
10020       if (l.eq.j+1 .and. l.gt.1) then
10021         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10022         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10023         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10024         vv(1)=pizda(1,1)-pizda(2,2)
10025         vv(2)=pizda(2,1)+pizda(1,2)
10026         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10027         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10028       else if (j.gt.1) then
10029         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10030         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10031         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10032         vv(1)=pizda(1,1)-pizda(2,2)
10033         vv(2)=pizda(2,1)+pizda(1,2)
10034         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10035         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10036           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10037         else
10038           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10039         endif
10040       endif
10041 ! Cartesian derivatives.
10042       do iii=1,2
10043         do kkk=1,5
10044           do lll=1,3
10045 #ifdef MOMENT
10046             if (iii.eq.1) then
10047               if (imat.eq.1) then
10048                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10049               else
10050                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10051               endif
10052             else
10053               if (imat.eq.1) then
10054                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10055               else
10056                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10057               endif
10058             endif
10059 #endif
10060             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
10061               auxvec(1))
10062             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10063             if (j.eq.l+1) then
10064               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10065                 b1(1,itj1),auxvec(1))
10066               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
10067             else
10068               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10069                 b1(1,itl1),auxvec(1))
10070               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
10071             endif
10072             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10073               pizda(1,1))
10074             vv(1)=pizda(1,1)-pizda(2,2)
10075             vv(2)=pizda(2,1)+pizda(1,2)
10076             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10077             if (swap) then
10078               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10079 #ifdef MOMENT
10080                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10081                    -(s1+s2+s4)
10082 #else
10083                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10084                    -(s2+s4)
10085 #endif
10086                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10087               else
10088 #ifdef MOMENT
10089                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10090 #else
10091                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10092 #endif
10093                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10094               endif
10095             else
10096 #ifdef MOMENT
10097               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10098 #else
10099               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10100 #endif
10101               if (l.eq.j+1) then
10102                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10103               else
10104                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10105               endif
10106             endif
10107           enddo
10108         enddo
10109       enddo
10110       return
10111       end function eello6_graph4
10112 !-----------------------------------------------------------------------------
10113       real(kind=8) function eello_turn6(i,jj,kk)
10114 !      implicit real*8 (a-h,o-z)
10115 !      include 'DIMENSIONS'
10116 !      include 'COMMON.IOUNITS'
10117 !      include 'COMMON.CHAIN'
10118 !      include 'COMMON.DERIV'
10119 !      include 'COMMON.INTERACT'
10120 !      include 'COMMON.CONTACTS'
10121 !      include 'COMMON.TORSION'
10122 !      include 'COMMON.VAR'
10123 !      include 'COMMON.GEO'
10124       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
10125       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
10126       real(kind=8),dimension(3) :: ggg1,ggg2
10127       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
10128       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
10129 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10130 !           the respective energy moment and not to the cluster cumulant.
10131 !el local variables
10132       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
10133       integer :: j1,j2,l1,l2,ll
10134       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
10135       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
10136       s1=0.0d0
10137       s8=0.0d0
10138       s13=0.0d0
10139 !
10140       eello_turn6=0.0d0
10141       j=i+4
10142       k=i+1
10143       l=i+3
10144       iti=itortyp(itype(i,1))
10145       itk=itortyp(itype(k,1))
10146       itk1=itortyp(itype(k+1,1))
10147       itl=itortyp(itype(l,1))
10148       itj=itortyp(itype(j,1))
10149 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10150 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
10151 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10152 !d        eello6=0.0d0
10153 !d        return
10154 !d      endif
10155 !d      write (iout,*)
10156 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10157 !d     &   ' and',k,l
10158 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
10159       do iii=1,2
10160         do kkk=1,5
10161           do lll=1,3
10162             derx_turn(lll,kkk,iii)=0.0d0
10163           enddo
10164         enddo
10165       enddo
10166 !d      eij=1.0d0
10167 !d      ekl=1.0d0
10168 !d      ekont=1.0d0
10169       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10170 !d      eello6_5=0.0d0
10171 !d      write (2,*) 'eello6_5',eello6_5
10172 #ifdef MOMENT
10173       call transpose2(AEA(1,1,1),auxmat(1,1))
10174       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10175       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10176       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10177 #endif
10178       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10179       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10180       s2 = scalar2(b1(1,itk),vtemp1(1))
10181 #ifdef MOMENT
10182       call transpose2(AEA(1,1,2),atemp(1,1))
10183       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10184       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10185       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10186 #endif
10187       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10188       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10189       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10190 #ifdef MOMENT
10191       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10192       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10193       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10194       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10195       ss13 = scalar2(b1(1,itk),vtemp4(1))
10196       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10197 #endif
10198 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10199 !      s1=0.0d0
10200 !      s2=0.0d0
10201 !      s8=0.0d0
10202 !      s12=0.0d0
10203 !      s13=0.0d0
10204       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10205 ! Derivatives in gamma(i+2)
10206       s1d =0.0d0
10207       s8d =0.0d0
10208 #ifdef MOMENT
10209       call transpose2(AEA(1,1,1),auxmatd(1,1))
10210       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10211       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10212       call transpose2(AEAderg(1,1,2),atempd(1,1))
10213       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10214       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10215 #endif
10216       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10217       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10218       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10219 !      s1d=0.0d0
10220 !      s2d=0.0d0
10221 !      s8d=0.0d0
10222 !      s12d=0.0d0
10223 !      s13d=0.0d0
10224       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10225 ! Derivatives in gamma(i+3)
10226 #ifdef MOMENT
10227       call transpose2(AEA(1,1,1),auxmatd(1,1))
10228       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10229       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10230       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10231 #endif
10232       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10233       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10234       s2d = scalar2(b1(1,itk),vtemp1d(1))
10235 #ifdef MOMENT
10236       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10237       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10238 #endif
10239       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10240 #ifdef MOMENT
10241       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10242       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10243       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10244 #endif
10245 !      s1d=0.0d0
10246 !      s2d=0.0d0
10247 !      s8d=0.0d0
10248 !      s12d=0.0d0
10249 !      s13d=0.0d0
10250 #ifdef MOMENT
10251       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10252                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10253 #else
10254       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10255                     -0.5d0*ekont*(s2d+s12d)
10256 #endif
10257 ! Derivatives in gamma(i+4)
10258       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10259       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10260       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10261 #ifdef MOMENT
10262       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10263       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10264       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10265 #endif
10266 !      s1d=0.0d0
10267 !      s2d=0.0d0
10268 !      s8d=0.0d0
10269 !      s12d=0.0d0
10270 !      s13d=0.0d0
10271 #ifdef MOMENT
10272       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10273 #else
10274       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10275 #endif
10276 ! Derivatives in gamma(i+5)
10277 #ifdef MOMENT
10278       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10279       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10280       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10281 #endif
10282       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10283       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10284       s2d = scalar2(b1(1,itk),vtemp1d(1))
10285 #ifdef MOMENT
10286       call transpose2(AEA(1,1,2),atempd(1,1))
10287       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10288       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10289 #endif
10290       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10291       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10292 #ifdef MOMENT
10293       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10294       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10295       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10296 #endif
10297 !      s1d=0.0d0
10298 !      s2d=0.0d0
10299 !      s8d=0.0d0
10300 !      s12d=0.0d0
10301 !      s13d=0.0d0
10302 #ifdef MOMENT
10303       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10304                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10305 #else
10306       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10307                     -0.5d0*ekont*(s2d+s12d)
10308 #endif
10309 ! Cartesian derivatives
10310       do iii=1,2
10311         do kkk=1,5
10312           do lll=1,3
10313 #ifdef MOMENT
10314             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10315             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10316             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10317 #endif
10318             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10319             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10320                 vtemp1d(1))
10321             s2d = scalar2(b1(1,itk),vtemp1d(1))
10322 #ifdef MOMENT
10323             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10324             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10325             s8d = -(atempd(1,1)+atempd(2,2))* &
10326                  scalar2(cc(1,1,itl),vtemp2(1))
10327 #endif
10328             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10329                  auxmatd(1,1))
10330             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10331             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10332 !      s1d=0.0d0
10333 !      s2d=0.0d0
10334 !      s8d=0.0d0
10335 !      s12d=0.0d0
10336 !      s13d=0.0d0
10337 #ifdef MOMENT
10338             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10339               - 0.5d0*(s1d+s2d)
10340 #else
10341             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10342               - 0.5d0*s2d
10343 #endif
10344 #ifdef MOMENT
10345             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10346               - 0.5d0*(s8d+s12d)
10347 #else
10348             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10349               - 0.5d0*s12d
10350 #endif
10351           enddo
10352         enddo
10353       enddo
10354 #ifdef MOMENT
10355       do kkk=1,5
10356         do lll=1,3
10357           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10358             achuj_tempd(1,1))
10359           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10360           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10361           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10362           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10363           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10364             vtemp4d(1))
10365           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10366           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10367           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10368         enddo
10369       enddo
10370 #endif
10371 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10372 !d     &  16*eel_turn6_num
10373 !d      goto 1112
10374       if (j.lt.nres-1) then
10375         j1=j+1
10376         j2=j-1
10377       else
10378         j1=j-1
10379         j2=j-2
10380       endif
10381       if (l.lt.nres-1) then
10382         l1=l+1
10383         l2=l-1
10384       else
10385         l1=l-1
10386         l2=l-2
10387       endif
10388       do ll=1,3
10389 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10390 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10391 !grad        ghalf=0.5d0*ggg1(ll)
10392 !d        ghalf=0.0d0
10393         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10394         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10395         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10396           +ekont*derx_turn(ll,2,1)
10397         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10398         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10399           +ekont*derx_turn(ll,4,1)
10400         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10401         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10402         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10403 !grad        ghalf=0.5d0*ggg2(ll)
10404 !d        ghalf=0.0d0
10405         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10406           +ekont*derx_turn(ll,2,2)
10407         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10408         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10409           +ekont*derx_turn(ll,4,2)
10410         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10411         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10412         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10413       enddo
10414 !d      goto 1112
10415 !grad      do m=i+1,j-1
10416 !grad        do ll=1,3
10417 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10418 !grad        enddo
10419 !grad      enddo
10420 !grad      do m=k+1,l-1
10421 !grad        do ll=1,3
10422 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10423 !grad        enddo
10424 !grad      enddo
10425 !grad1112  continue
10426 !grad      do m=i+2,j2
10427 !grad        do ll=1,3
10428 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10429 !grad        enddo
10430 !grad      enddo
10431 !grad      do m=k+2,l2
10432 !grad        do ll=1,3
10433 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10434 !grad        enddo
10435 !grad      enddo
10436 !d      do iii=1,nres-3
10437 !d        write (2,*) iii,g_corr6_loc(iii)
10438 !d      enddo
10439       eello_turn6=ekont*eel_turn6
10440 !d      write (2,*) 'ekont',ekont
10441 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10442       return
10443       end function eello_turn6
10444 !-----------------------------------------------------------------------------
10445       subroutine MATVEC2(A1,V1,V2)
10446 !DIR$ INLINEALWAYS MATVEC2
10447 #ifndef OSF
10448 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10449 #endif
10450 !      implicit real*8 (a-h,o-z)
10451 !      include 'DIMENSIONS'
10452       real(kind=8),dimension(2) :: V1,V2
10453       real(kind=8),dimension(2,2) :: A1
10454       real(kind=8) :: vaux1,vaux2
10455 !      DO 1 I=1,2
10456 !        VI=0.0
10457 !        DO 3 K=1,2
10458 !    3     VI=VI+A1(I,K)*V1(K)
10459 !        Vaux(I)=VI
10460 !    1 CONTINUE
10461
10462       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10463       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10464
10465       v2(1)=vaux1
10466       v2(2)=vaux2
10467       end subroutine MATVEC2
10468 !-----------------------------------------------------------------------------
10469       subroutine MATMAT2(A1,A2,A3)
10470 #ifndef OSF
10471 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10472 #endif
10473 !      implicit real*8 (a-h,o-z)
10474 !      include 'DIMENSIONS'
10475       real(kind=8),dimension(2,2) :: A1,A2,A3
10476       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10477 !      DIMENSION AI3(2,2)
10478 !        DO  J=1,2
10479 !          A3IJ=0.0
10480 !          DO K=1,2
10481 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10482 !          enddo
10483 !          A3(I,J)=A3IJ
10484 !       enddo
10485 !      enddo
10486
10487       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10488       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10489       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10490       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10491
10492       A3(1,1)=AI3_11
10493       A3(2,1)=AI3_21
10494       A3(1,2)=AI3_12
10495       A3(2,2)=AI3_22
10496       end subroutine MATMAT2
10497 !-----------------------------------------------------------------------------
10498       real(kind=8) function scalar2(u,v)
10499 !DIR$ INLINEALWAYS scalar2
10500       implicit none
10501       real(kind=8),dimension(2) :: u,v
10502       real(kind=8) :: sc
10503       integer :: i
10504       scalar2=u(1)*v(1)+u(2)*v(2)
10505       return
10506       end function scalar2
10507 !-----------------------------------------------------------------------------
10508       subroutine transpose2(a,at)
10509 !DIR$ INLINEALWAYS transpose2
10510 #ifndef OSF
10511 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10512 #endif
10513       implicit none
10514       real(kind=8),dimension(2,2) :: a,at
10515       at(1,1)=a(1,1)
10516       at(1,2)=a(2,1)
10517       at(2,1)=a(1,2)
10518       at(2,2)=a(2,2)
10519       return
10520       end subroutine transpose2
10521 !-----------------------------------------------------------------------------
10522       subroutine transpose(n,a,at)
10523       implicit none
10524       integer :: n,i,j
10525       real(kind=8),dimension(n,n) :: a,at
10526       do i=1,n
10527         do j=1,n
10528           at(j,i)=a(i,j)
10529         enddo
10530       enddo
10531       return
10532       end subroutine transpose
10533 !-----------------------------------------------------------------------------
10534       subroutine prodmat3(a1,a2,kk,transp,prod)
10535 !DIR$ INLINEALWAYS prodmat3
10536 #ifndef OSF
10537 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10538 #endif
10539       implicit none
10540       integer :: i,j
10541       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10542       logical :: transp
10543 !rc      double precision auxmat(2,2),prod_(2,2)
10544
10545       if (transp) then
10546 !rc        call transpose2(kk(1,1),auxmat(1,1))
10547 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10548 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10549
10550            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
10551        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10552            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
10553        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10554            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
10555        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10556            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10557        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10558
10559       else
10560 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10561 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10562
10563            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
10564         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10565            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
10566         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10567            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
10568         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10569            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
10570         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10571
10572       endif
10573 !      call transpose2(a2(1,1),a2t(1,1))
10574
10575 !rc      print *,transp
10576 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
10577 !rc      print *,((prod(i,j),i=1,2),j=1,2)
10578
10579       return
10580       end subroutine prodmat3
10581 !-----------------------------------------------------------------------------
10582 ! energy_p_new_barrier.F
10583 !-----------------------------------------------------------------------------
10584       subroutine sum_gradient
10585 !      implicit real*8 (a-h,o-z)
10586       use io_base, only: pdbout
10587 !      include 'DIMENSIONS'
10588 #ifndef ISNAN
10589       external proc_proc
10590 #ifdef WINPGI
10591 !MS$ATTRIBUTES C ::  proc_proc
10592 #endif
10593 #endif
10594 #ifdef MPI
10595       include 'mpif.h'
10596 #endif
10597       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10598                    gloc_scbuf !(3,maxres)
10599
10600       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10601 !#endif
10602 !el local variables
10603       integer :: i,j,k,ierror,ierr
10604       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10605                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10606                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10607                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10608                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10609                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10610                    gsccorr_max,gsccorrx_max,time00
10611
10612 !      include 'COMMON.SETUP'
10613 !      include 'COMMON.IOUNITS'
10614 !      include 'COMMON.FFIELD'
10615 !      include 'COMMON.DERIV'
10616 !      include 'COMMON.INTERACT'
10617 !      include 'COMMON.SBRIDGE'
10618 !      include 'COMMON.CHAIN'
10619 !      include 'COMMON.VAR'
10620 !      include 'COMMON.CONTROL'
10621 !      include 'COMMON.TIME1'
10622 !      include 'COMMON.MAXGRAD'
10623 !      include 'COMMON.SCCOR'
10624 #ifdef TIMING
10625       time01=MPI_Wtime()
10626 #endif
10627 #ifdef DEBUG
10628       write (iout,*) "sum_gradient gvdwc, gvdwx"
10629       do i=1,nres
10630         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10631          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10632       enddo
10633       call flush(iout)
10634 #endif
10635 #ifdef MPI
10636         gradbufc=0.0d0
10637         gradbufx=0.0d0
10638         gradbufc_sum=0.0d0
10639         gloc_scbuf=0.0d0
10640         glocbuf=0.0d0
10641 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10642         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10643           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10644 #endif
10645 !
10646 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10647 !            in virtual-bond-vector coordinates
10648 !
10649 #ifdef DEBUG
10650 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10651 !      do i=1,nres-1
10652 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10653 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10654 !      enddo
10655 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10656 !      do i=1,nres-1
10657 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10658 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10659 !      enddo
10660       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10661       do i=1,nres
10662         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10663          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10664          (gvdwc_scpp(j,i),j=1,3)
10665       enddo
10666       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10667       do i=1,nres
10668         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10669          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10670          (gelc_loc_long(j,i),j=1,3)
10671       enddo
10672       call flush(iout)
10673 #endif
10674 #ifdef SPLITELE
10675       do i=0,nct
10676         do j=1,3
10677           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10678                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10679                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10680                       wel_loc*gel_loc_long(j,i)+ &
10681                       wcorr*gradcorr_long(j,i)+ &
10682                       wcorr5*gradcorr5_long(j,i)+ &
10683                       wcorr6*gradcorr6_long(j,i)+ &
10684                       wturn6*gcorr6_turn_long(j,i)+ &
10685                       wstrain*ghpbc(j,i) &
10686                      +wliptran*gliptranc(j,i) &
10687                      +gradafm(j,i) &
10688                      +welec*gshieldc(j,i) &
10689                      +wcorr*gshieldc_ec(j,i) &
10690                      +wturn3*gshieldc_t3(j,i)&
10691                      +wturn4*gshieldc_t4(j,i)&
10692                      +wel_loc*gshieldc_ll(j,i)&
10693                      +wtube*gg_tube(j,i) &
10694                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10695                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10696                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10697                      wcorr_nucl*gradcorr_nucl(j,i)&
10698                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
10699                      wcatprot* gradpepcat(j,i)+ &
10700                      wcatcat*gradcatcat(j,i)+   &
10701                      wscbase*gvdwc_scbase(j,i)+ &
10702                      wpepbase*gvdwc_pepbase(j,i)+&
10703                      wscpho*gvdwc_scpho(j,i)+   &
10704                      wpeppho*gvdwc_peppho(j,i)
10705
10706
10707
10708
10709
10710         enddo
10711       enddo
10712 #else
10713       do i=0,nct
10714         do j=1,3
10715           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10716                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10717                       welec*gelc_long(j,i)+ &
10718                       wbond*gradb(j,i)+ &
10719                       wel_loc*gel_loc_long(j,i)+ &
10720                       wcorr*gradcorr_long(j,i)+ &
10721                       wcorr5*gradcorr5_long(j,i)+ &
10722                       wcorr6*gradcorr6_long(j,i)+ &
10723                       wturn6*gcorr6_turn_long(j,i)+ &
10724                       wstrain*ghpbc(j,i) &
10725                      +wliptran*gliptranc(j,i) &
10726                      +gradafm(j,i) &
10727                      +welec*gshieldc(j,i)&
10728                      +wcorr*gshieldc_ec(j,i) &
10729                      +wturn4*gshieldc_t4(j,i) &
10730                      +wel_loc*gshieldc_ll(j,i)&
10731                      +wtube*gg_tube(j,i) &
10732                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10733                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10734                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10735                      wcorr_nucl*gradcorr_nucl(j,i) &
10736                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
10737                      wcatprot* gradpepcat(j,i)+ &
10738                      wcatcat*gradcatcat(j,i)+   &
10739                      wscbase*gvdwc_scbase(j,i)  &
10740                      wpepbase*gvdwc_pepbase(j,i)+&
10741                      wscpho*gvdwc_scpho(j,i)+&
10742                      wpeppho*gvdwc_peppho(j,i)
10743
10744
10745         enddo
10746       enddo
10747 #endif
10748 #ifdef MPI
10749       if (nfgtasks.gt.1) then
10750       time00=MPI_Wtime()
10751 #ifdef DEBUG
10752       write (iout,*) "gradbufc before allreduce"
10753       do i=1,nres
10754         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10755       enddo
10756       call flush(iout)
10757 #endif
10758       do i=0,nres
10759         do j=1,3
10760           gradbufc_sum(j,i)=gradbufc(j,i)
10761         enddo
10762       enddo
10763 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10764 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10765 !      time_reduce=time_reduce+MPI_Wtime()-time00
10766 #ifdef DEBUG
10767 !      write (iout,*) "gradbufc_sum after allreduce"
10768 !      do i=1,nres
10769 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10770 !      enddo
10771 !      call flush(iout)
10772 #endif
10773 #ifdef TIMING
10774 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10775 #endif
10776       do i=0,nres
10777         do k=1,3
10778           gradbufc(k,i)=0.0d0
10779         enddo
10780       enddo
10781 #ifdef DEBUG
10782       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10783       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10784                         " jgrad_end  ",jgrad_end(i),&
10785                         i=igrad_start,igrad_end)
10786 #endif
10787 !
10788 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10789 ! do not parallelize this part.
10790 !
10791 !      do i=igrad_start,igrad_end
10792 !        do j=jgrad_start(i),jgrad_end(i)
10793 !          do k=1,3
10794 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10795 !          enddo
10796 !        enddo
10797 !      enddo
10798       do j=1,3
10799         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10800       enddo
10801       do i=nres-2,-1,-1
10802         do j=1,3
10803           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10804         enddo
10805       enddo
10806 #ifdef DEBUG
10807       write (iout,*) "gradbufc after summing"
10808       do i=1,nres
10809         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10810       enddo
10811       call flush(iout)
10812 #endif
10813       else
10814 #endif
10815 !el#define DEBUG
10816 #ifdef DEBUG
10817       write (iout,*) "gradbufc"
10818       do i=1,nres
10819         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10820       enddo
10821       call flush(iout)
10822 #endif
10823 !el#undef DEBUG
10824       do i=-1,nres
10825         do j=1,3
10826           gradbufc_sum(j,i)=gradbufc(j,i)
10827           gradbufc(j,i)=0.0d0
10828         enddo
10829       enddo
10830       do j=1,3
10831         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10832       enddo
10833       do i=nres-2,-1,-1
10834         do j=1,3
10835           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10836         enddo
10837       enddo
10838 !      do i=nnt,nres-1
10839 !        do k=1,3
10840 !          gradbufc(k,i)=0.0d0
10841 !        enddo
10842 !        do j=i+1,nres
10843 !          do k=1,3
10844 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10845 !          enddo
10846 !        enddo
10847 !      enddo
10848 !el#define DEBUG
10849 #ifdef DEBUG
10850       write (iout,*) "gradbufc after summing"
10851       do i=1,nres
10852         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10853       enddo
10854       call flush(iout)
10855 #endif
10856 !el#undef DEBUG
10857 #ifdef MPI
10858       endif
10859 #endif
10860       do k=1,3
10861         gradbufc(k,nres)=0.0d0
10862       enddo
10863 !el----------------
10864 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10865 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10866 !el-----------------
10867       do i=-1,nct
10868         do j=1,3
10869 #ifdef SPLITELE
10870           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10871                       wel_loc*gel_loc(j,i)+ &
10872                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10873                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10874                       wel_loc*gel_loc_long(j,i)+ &
10875                       wcorr*gradcorr_long(j,i)+ &
10876                       wcorr5*gradcorr5_long(j,i)+ &
10877                       wcorr6*gradcorr6_long(j,i)+ &
10878                       wturn6*gcorr6_turn_long(j,i))+ &
10879                       wbond*gradb(j,i)+ &
10880                       wcorr*gradcorr(j,i)+ &
10881                       wturn3*gcorr3_turn(j,i)+ &
10882                       wturn4*gcorr4_turn(j,i)+ &
10883                       wcorr5*gradcorr5(j,i)+ &
10884                       wcorr6*gradcorr6(j,i)+ &
10885                       wturn6*gcorr6_turn(j,i)+ &
10886                       wsccor*gsccorc(j,i) &
10887                      +wscloc*gscloc(j,i)  &
10888                      +wliptran*gliptranc(j,i) &
10889                      +gradafm(j,i) &
10890                      +welec*gshieldc(j,i) &
10891                      +welec*gshieldc_loc(j,i) &
10892                      +wcorr*gshieldc_ec(j,i) &
10893                      +wcorr*gshieldc_loc_ec(j,i) &
10894                      +wturn3*gshieldc_t3(j,i) &
10895                      +wturn3*gshieldc_loc_t3(j,i) &
10896                      +wturn4*gshieldc_t4(j,i) &
10897                      +wturn4*gshieldc_loc_t4(j,i) &
10898                      +wel_loc*gshieldc_ll(j,i) &
10899                      +wel_loc*gshieldc_loc_ll(j,i) &
10900                      +wtube*gg_tube(j,i) &
10901                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10902                      +wvdwpsb*gvdwpsb1(j,i))&
10903                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
10904 !                      if (i.eq.21) then
10905 !                      print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),&
10906 !                      wturn4*gshieldc_t4(j,i), &
10907 !                     wturn4*gshieldc_loc_t4(j,i)
10908 !                       endif
10909 !                 if ((i.le.2).and.(i.ge.1))
10910 !                       print *,gradc(j,i,icg),&
10911 !                      gradbufc(j,i),welec*gelc(j,i), &
10912 !                      wel_loc*gel_loc(j,i), &
10913 !                      wscp*gvdwc_scpp(j,i), &
10914 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
10915 !                      wel_loc*gel_loc_long(j,i), &
10916 !                      wcorr*gradcorr_long(j,i), &
10917 !                      wcorr5*gradcorr5_long(j,i), &
10918 !                      wcorr6*gradcorr6_long(j,i), &
10919 !                      wturn6*gcorr6_turn_long(j,i), &
10920 !                      wbond*gradb(j,i), &
10921 !                      wcorr*gradcorr(j,i), &
10922 !                      wturn3*gcorr3_turn(j,i), &
10923 !                      wturn4*gcorr4_turn(j,i), &
10924 !                      wcorr5*gradcorr5(j,i), &
10925 !                      wcorr6*gradcorr6(j,i), &
10926 !                      wturn6*gcorr6_turn(j,i), &
10927 !                      wsccor*gsccorc(j,i) &
10928 !                     ,wscloc*gscloc(j,i)  &
10929 !                     ,wliptran*gliptranc(j,i) &
10930 !                    ,gradafm(j,i) &
10931 !                     ,welec*gshieldc(j,i) &
10932 !                     ,welec*gshieldc_loc(j,i) &
10933 !                     ,wcorr*gshieldc_ec(j,i) &
10934 !                     ,wcorr*gshieldc_loc_ec(j,i) &
10935 !                     ,wturn3*gshieldc_t3(j,i) &
10936 !                     ,wturn3*gshieldc_loc_t3(j,i) &
10937 !                     ,wturn4*gshieldc_t4(j,i) &
10938 !                     ,wturn4*gshieldc_loc_t4(j,i) &
10939 !                     ,wel_loc*gshieldc_ll(j,i) &
10940 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
10941 !                     ,wtube*gg_tube(j,i) &
10942 !                     ,wbond_nucl*gradb_nucl(j,i) &
10943 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
10944 !                     wvdwpsb*gvdwpsb1(j,i)&
10945 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
10946 !
10947
10948 #else
10949           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10950                       wel_loc*gel_loc(j,i)+ &
10951                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10952                       welec*gelc_long(j,i)+ &
10953                       wel_loc*gel_loc_long(j,i)+ &
10954 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
10955                       wcorr5*gradcorr5_long(j,i)+ &
10956                       wcorr6*gradcorr6_long(j,i)+ &
10957                       wturn6*gcorr6_turn_long(j,i))+ &
10958                       wbond*gradb(j,i)+ &
10959                       wcorr*gradcorr(j,i)+ &
10960                       wturn3*gcorr3_turn(j,i)+ &
10961                       wturn4*gcorr4_turn(j,i)+ &
10962                       wcorr5*gradcorr5(j,i)+ &
10963                       wcorr6*gradcorr6(j,i)+ &
10964                       wturn6*gcorr6_turn(j,i)+ &
10965                       wsccor*gsccorc(j,i) &
10966                      +wscloc*gscloc(j,i) &
10967                      +gradafm(j,i) &
10968                      +wliptran*gliptranc(j,i) &
10969                      +welec*gshieldc(j,i) &
10970                      +welec*gshieldc_loc(j,) &
10971                      +wcorr*gshieldc_ec(j,i) &
10972                      +wcorr*gshieldc_loc_ec(j,i) &
10973                      +wturn3*gshieldc_t3(j,i) &
10974                      +wturn3*gshieldc_loc_t3(j,i) &
10975                      +wturn4*gshieldc_t4(j,i) &
10976                      +wturn4*gshieldc_loc_t4(j,i) &
10977                      +wel_loc*gshieldc_ll(j,i) &
10978                      +wel_loc*gshieldc_loc_ll(j,i) &
10979                      +wtube*gg_tube(j,i) &
10980                      +wbond_nucl*gradb_nucl(j,i) &
10981                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10982                      +wvdwpsb*gvdwpsb1(j,i))&
10983                      +wsbloc*gsbloc(j,i)
10984
10985
10986
10987
10988 #endif
10989           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
10990                         wbond*gradbx(j,i)+ &
10991                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
10992                         wsccor*gsccorx(j,i) &
10993                        +wscloc*gsclocx(j,i) &
10994                        +wliptran*gliptranx(j,i) &
10995                        +welec*gshieldx(j,i)     &
10996                        +wcorr*gshieldx_ec(j,i)  &
10997                        +wturn3*gshieldx_t3(j,i) &
10998                        +wturn4*gshieldx_t4(j,i) &
10999                        +wel_loc*gshieldx_ll(j,i)&
11000                        +wtube*gg_tube_sc(j,i)   &
11001                        +wbond_nucl*gradbx_nucl(j,i) &
11002                        +wvdwsb*gvdwsbx(j,i) &
11003                        +welsb*gelsbx(j,i) &
11004                        +wcorr_nucl*gradxorr_nucl(j,i)&
11005                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
11006                        +wsbloc*gsblocx(j,i) &
11007                        +wcatprot* gradpepcatx(j,i)&
11008                        +wscbase*gvdwx_scbase(j,i) &
11009                        +wpepbase*gvdwx_pepbase(j,i)&
11010                        +wscpho*gvdwx_scpho(j,i)
11011 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
11012
11013         enddo
11014       enddo
11015 !#define DEBUG
11016 #ifdef DEBUG
11017       write (iout,*) "gloc before adding corr"
11018       do i=1,4*nres
11019         write (iout,*) i,gloc(i,icg)
11020       enddo
11021 #endif
11022       do i=1,nres-3
11023         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
11024          +wcorr5*g_corr5_loc(i) &
11025          +wcorr6*g_corr6_loc(i) &
11026          +wturn4*gel_loc_turn4(i) &
11027          +wturn3*gel_loc_turn3(i) &
11028          +wturn6*gel_loc_turn6(i) &
11029          +wel_loc*gel_loc_loc(i)
11030       enddo
11031 #ifdef DEBUG
11032       write (iout,*) "gloc after adding corr"
11033       do i=1,4*nres
11034         write (iout,*) i,gloc(i,icg)
11035       enddo
11036 #endif
11037 !#undef DEBUG
11038 #ifdef MPI
11039       if (nfgtasks.gt.1) then
11040         do j=1,3
11041           do i=0,nres
11042             gradbufc(j,i)=gradc(j,i,icg)
11043             gradbufx(j,i)=gradx(j,i,icg)
11044           enddo
11045         enddo
11046         do i=1,4*nres
11047           glocbuf(i)=gloc(i,icg)
11048         enddo
11049 !#define DEBUG
11050 #ifdef DEBUG
11051       write (iout,*) "gloc_sc before reduce"
11052       do i=1,nres
11053        do j=1,1
11054         write (iout,*) i,j,gloc_sc(j,i,icg)
11055        enddo
11056       enddo
11057 #endif
11058 !#undef DEBUG
11059         do i=1,nres
11060          do j=1,3
11061           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
11062          enddo
11063         enddo
11064         time00=MPI_Wtime()
11065         call MPI_Barrier(FG_COMM,IERR)
11066         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
11067         time00=MPI_Wtime()
11068         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
11069           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11070         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
11071           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11072         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
11073           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11074         time_reduce=time_reduce+MPI_Wtime()-time00
11075         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
11076           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11077         time_reduce=time_reduce+MPI_Wtime()-time00
11078 !#define DEBUG
11079 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
11080 #ifdef DEBUG
11081       write (iout,*) "gloc_sc after reduce"
11082       do i=1,nres
11083        do j=1,1
11084         write (iout,*) i,j,gloc_sc(j,i,icg)
11085        enddo
11086       enddo
11087 #endif
11088 !#undef DEBUG
11089 #ifdef DEBUG
11090       write (iout,*) "gloc after reduce"
11091       do i=1,4*nres
11092         write (iout,*) i,gloc(i,icg)
11093       enddo
11094 #endif
11095       endif
11096 #endif
11097       if (gnorm_check) then
11098 !
11099 ! Compute the maximum elements of the gradient
11100 !
11101       gvdwc_max=0.0d0
11102       gvdwc_scp_max=0.0d0
11103       gelc_max=0.0d0
11104       gvdwpp_max=0.0d0
11105       gradb_max=0.0d0
11106       ghpbc_max=0.0d0
11107       gradcorr_max=0.0d0
11108       gel_loc_max=0.0d0
11109       gcorr3_turn_max=0.0d0
11110       gcorr4_turn_max=0.0d0
11111       gradcorr5_max=0.0d0
11112       gradcorr6_max=0.0d0
11113       gcorr6_turn_max=0.0d0
11114       gsccorc_max=0.0d0
11115       gscloc_max=0.0d0
11116       gvdwx_max=0.0d0
11117       gradx_scp_max=0.0d0
11118       ghpbx_max=0.0d0
11119       gradxorr_max=0.0d0
11120       gsccorx_max=0.0d0
11121       gsclocx_max=0.0d0
11122       do i=1,nct
11123         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
11124         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
11125         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
11126         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
11127          gvdwc_scp_max=gvdwc_scp_norm
11128         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
11129         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
11130         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
11131         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
11132         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
11133         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
11134         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
11135         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
11136         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
11137         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
11138         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
11139         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
11140         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
11141           gcorr3_turn(1,i)))
11142         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
11143           gcorr3_turn_max=gcorr3_turn_norm
11144         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
11145           gcorr4_turn(1,i)))
11146         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
11147           gcorr4_turn_max=gcorr4_turn_norm
11148         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
11149         if (gradcorr5_norm.gt.gradcorr5_max) &
11150           gradcorr5_max=gradcorr5_norm
11151         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
11152         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
11153         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
11154           gcorr6_turn(1,i)))
11155         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
11156           gcorr6_turn_max=gcorr6_turn_norm
11157         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
11158         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
11159         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
11160         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
11161         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
11162         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
11163         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
11164         if (gradx_scp_norm.gt.gradx_scp_max) &
11165           gradx_scp_max=gradx_scp_norm
11166         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
11167         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
11168         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
11169         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
11170         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
11171         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
11172         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
11173         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11174       enddo
11175       if (gradout) then
11176 #ifdef AIX
11177         open(istat,file=statname,position="append")
11178 #else
11179         open(istat,file=statname,access="append")
11180 #endif
11181         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11182            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11183            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11184            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11185            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11186            gsccorx_max,gsclocx_max
11187         close(istat)
11188         if (gvdwc_max.gt.1.0d4) then
11189           write (iout,*) "gvdwc gvdwx gradb gradbx"
11190           do i=nnt,nct
11191             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11192               gradb(j,i),gradbx(j,i),j=1,3)
11193           enddo
11194           call pdbout(0.0d0,'cipiszcze',iout)
11195           call flush(iout)
11196         endif
11197       endif
11198       endif
11199 !#define DEBUG
11200 #ifdef DEBUG
11201       write (iout,*) "gradc gradx gloc"
11202       do i=1,nres
11203         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11204          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11205       enddo
11206 #endif
11207 !#undef DEBUG
11208 #ifdef TIMING
11209       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11210 #endif
11211       return
11212       end subroutine sum_gradient
11213 !-----------------------------------------------------------------------------
11214       subroutine sc_grad
11215 !      implicit real*8 (a-h,o-z)
11216       use calc_data
11217 !      include 'DIMENSIONS'
11218 !      include 'COMMON.CHAIN'
11219 !      include 'COMMON.DERIV'
11220 !      include 'COMMON.CALC'
11221 !      include 'COMMON.IOUNITS'
11222       real(kind=8), dimension(3) :: dcosom1,dcosom2
11223 !      print *,"wchodze"
11224       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11225           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11226       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11227           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11228
11229       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11230            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11231            +dCAVdOM12+ dGCLdOM12
11232 ! diagnostics only
11233 !      eom1=0.0d0
11234 !      eom2=0.0d0
11235 !      eom12=evdwij*eps1_om12
11236 ! end diagnostics
11237 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11238 !       " sigder",sigder
11239 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11240 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11241 !C      print *,sss_ele_cut,'in sc_grad'
11242       do k=1,3
11243         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11244         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11245       enddo
11246       do k=1,3
11247         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11248 !C      print *,'gg',k,gg(k)
11249        enddo
11250 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11251 !      write (iout,*) "gg",(gg(k),k=1,3)
11252       do k=1,3
11253         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11254                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11255                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11256                   *sss_ele_cut
11257
11258         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11259                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11260                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11261                   *sss_ele_cut
11262
11263 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11264 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11265 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11266 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11267       enddo
11268 !
11269 ! Calculate the components of the gradient in DC and X
11270 !
11271 !grad      do k=i,j-1
11272 !grad        do l=1,3
11273 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11274 !grad        enddo
11275 !grad      enddo
11276       do l=1,3
11277         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11278         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11279       enddo
11280       return
11281       end subroutine sc_grad
11282 #ifdef CRYST_THETA
11283 !-----------------------------------------------------------------------------
11284       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11285
11286       use comm_calcthet
11287 !      implicit real*8 (a-h,o-z)
11288 !      include 'DIMENSIONS'
11289 !      include 'COMMON.LOCAL'
11290 !      include 'COMMON.IOUNITS'
11291 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11292 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11293 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11294       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11295       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11296 !el      integer :: it
11297 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11298 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11299 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11300 !el local variables
11301
11302       delthec=thetai-thet_pred_mean
11303       delthe0=thetai-theta0i
11304 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11305       t3 = thetai-thet_pred_mean
11306       t6 = t3**2
11307       t9 = term1
11308       t12 = t3*sigcsq
11309       t14 = t12+t6*sigsqtc
11310       t16 = 1.0d0
11311       t21 = thetai-theta0i
11312       t23 = t21**2
11313       t26 = term2
11314       t27 = t21*t26
11315       t32 = termexp
11316       t40 = t32**2
11317       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11318        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11319        *(-t12*t9-ak*sig0inv*t27)
11320       return
11321       end subroutine mixder
11322 #endif
11323 !-----------------------------------------------------------------------------
11324 ! cartder.F
11325 !-----------------------------------------------------------------------------
11326       subroutine cartder
11327 !-----------------------------------------------------------------------------
11328 ! This subroutine calculates the derivatives of the consecutive virtual
11329 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11330 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11331 ! in the angles alpha and omega, describing the location of a side chain
11332 ! in its local coordinate system.
11333 !
11334 ! The derivatives are stored in the following arrays:
11335 !
11336 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11337 ! The structure is as follows:
11338 !
11339 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11340 ! 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)
11341 !         . . . . . . . . . . . .  . . . . . .
11342 ! 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)
11343 !                          .
11344 !                          .
11345 !                          .
11346 ! 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)
11347 !
11348 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11349 ! The structure is same as above.
11350 !
11351 ! DCDS - the derivatives of the side chain vectors in the local spherical
11352 ! andgles alph and omega:
11353 !
11354 ! 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)
11355 ! 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)
11356 !                          .
11357 !                          .
11358 !                          .
11359 ! 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)
11360 !
11361 ! Version of March '95, based on an early version of November '91.
11362 !
11363 !**********************************************************************
11364 !      implicit real*8 (a-h,o-z)
11365 !      include 'DIMENSIONS'
11366 !      include 'COMMON.VAR'
11367 !      include 'COMMON.CHAIN'
11368 !      include 'COMMON.DERIV'
11369 !      include 'COMMON.GEO'
11370 !      include 'COMMON.LOCAL'
11371 !      include 'COMMON.INTERACT'
11372       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11373       real(kind=8),dimension(3,3) :: dp,temp
11374 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11375       real(kind=8),dimension(3) :: xx,xx1
11376 !el local variables
11377       integer :: i,k,l,j,m,ind,ind1,jjj
11378       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11379                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11380                  sint2,xp,yp,xxp,yyp,zzp,dj
11381
11382 !      common /przechowalnia/ fromto
11383       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11384 ! get the position of the jth ijth fragment of the chain coordinate system
11385 ! in the fromto array.
11386 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11387 !
11388 !      maxdim=(nres-1)*(nres-2)/2
11389 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11390 ! calculate the derivatives of transformation matrix elements in theta
11391 !
11392
11393 !el      call flush(iout) !el
11394       do i=1,nres-2
11395         rdt(1,1,i)=-rt(1,2,i)
11396         rdt(1,2,i)= rt(1,1,i)
11397         rdt(1,3,i)= 0.0d0
11398         rdt(2,1,i)=-rt(2,2,i)
11399         rdt(2,2,i)= rt(2,1,i)
11400         rdt(2,3,i)= 0.0d0
11401         rdt(3,1,i)=-rt(3,2,i)
11402         rdt(3,2,i)= rt(3,1,i)
11403         rdt(3,3,i)= 0.0d0
11404       enddo
11405 !
11406 ! derivatives in phi
11407 !
11408       do i=2,nres-2
11409         drt(1,1,i)= 0.0d0
11410         drt(1,2,i)= 0.0d0
11411         drt(1,3,i)= 0.0d0
11412         drt(2,1,i)= rt(3,1,i)
11413         drt(2,2,i)= rt(3,2,i)
11414         drt(2,3,i)= rt(3,3,i)
11415         drt(3,1,i)=-rt(2,1,i)
11416         drt(3,2,i)=-rt(2,2,i)
11417         drt(3,3,i)=-rt(2,3,i)
11418       enddo
11419 !
11420 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
11421 !
11422       do i=2,nres-2
11423         ind=indmat(i,i+1)
11424         do k=1,3
11425           do l=1,3
11426             temp(k,l)=rt(k,l,i)
11427           enddo
11428         enddo
11429         do k=1,3
11430           do l=1,3
11431             fromto(k,l,ind)=temp(k,l)
11432           enddo
11433         enddo
11434         do j=i+1,nres-2
11435           ind=indmat(i,j+1)
11436           do k=1,3
11437             do l=1,3
11438               dpkl=0.0d0
11439               do m=1,3
11440                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
11441               enddo
11442               dp(k,l)=dpkl
11443               fromto(k,l,ind)=dpkl
11444             enddo
11445           enddo
11446           do k=1,3
11447             do l=1,3
11448               temp(k,l)=dp(k,l)
11449             enddo
11450           enddo
11451         enddo
11452       enddo
11453 !
11454 ! Calculate derivatives.
11455 !
11456       ind1=0
11457       do i=1,nres-2
11458       ind1=ind1+1
11459 !
11460 ! Derivatives of DC(i+1) in theta(i+2)
11461 !
11462         do j=1,3
11463           do k=1,2
11464             dpjk=0.0D0
11465             do l=1,3
11466               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
11467             enddo
11468             dp(j,k)=dpjk
11469             prordt(j,k,i)=dp(j,k)
11470           enddo
11471           dp(j,3)=0.0D0
11472           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
11473         enddo
11474 !
11475 ! Derivatives of SC(i+1) in theta(i+2)
11476 !
11477         xx1(1)=-0.5D0*xloc(2,i+1)
11478         xx1(2)= 0.5D0*xloc(1,i+1)
11479         do j=1,3
11480           xj=0.0D0
11481           do k=1,2
11482             xj=xj+r(j,k,i)*xx1(k)
11483           enddo
11484           xx(j)=xj
11485         enddo
11486         do j=1,3
11487           rj=0.0D0
11488           do k=1,3
11489             rj=rj+prod(j,k,i)*xx(k)
11490           enddo
11491           dxdv(j,ind1)=rj
11492         enddo
11493 !
11494 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
11495 ! than the other off-diagonal derivatives.
11496 !
11497         do j=1,3
11498           dxoiij=0.0D0
11499           do k=1,3
11500             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11501           enddo
11502           dxdv(j,ind1+1)=dxoiij
11503         enddo
11504 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
11505 !
11506 ! Derivatives of DC(i+1) in phi(i+2)
11507 !
11508         do j=1,3
11509           do k=1,3
11510             dpjk=0.0
11511             do l=2,3
11512               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
11513             enddo
11514             dp(j,k)=dpjk
11515             prodrt(j,k,i)=dp(j,k)
11516           enddo
11517           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
11518         enddo
11519 !
11520 ! Derivatives of SC(i+1) in phi(i+2)
11521 !
11522         xx(1)= 0.0D0
11523         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
11524         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
11525         do j=1,3
11526           rj=0.0D0
11527           do k=2,3
11528             rj=rj+prod(j,k,i)*xx(k)
11529           enddo
11530           dxdv(j+3,ind1)=-rj
11531         enddo
11532 !
11533 ! Derivatives of SC(i+1) in phi(i+3).
11534 !
11535         do j=1,3
11536           dxoiij=0.0D0
11537           do k=1,3
11538             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11539           enddo
11540           dxdv(j+3,ind1+1)=dxoiij
11541         enddo
11542 !
11543 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
11544 ! theta(nres) and phi(i+3) thru phi(nres).
11545 !
11546         do j=i+1,nres-2
11547         ind1=ind1+1
11548         ind=indmat(i+1,j+1)
11549 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
11550           do k=1,3
11551             do l=1,3
11552               tempkl=0.0D0
11553               do m=1,2
11554                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
11555               enddo
11556               temp(k,l)=tempkl
11557             enddo
11558           enddo
11559 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
11560 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
11561 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
11562 ! Derivatives of virtual-bond vectors in theta
11563           do k=1,3
11564             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
11565           enddo
11566 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
11567 ! Derivatives of SC vectors in theta
11568           do k=1,3
11569             dxoijk=0.0D0
11570             do l=1,3
11571               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11572             enddo
11573             dxdv(k,ind1+1)=dxoijk
11574           enddo
11575 !
11576 !--- Calculate the derivatives in phi
11577 !
11578           do k=1,3
11579             do l=1,3
11580               tempkl=0.0D0
11581               do m=1,3
11582                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
11583               enddo
11584               temp(k,l)=tempkl
11585             enddo
11586           enddo
11587           do k=1,3
11588             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
11589         enddo
11590           do k=1,3
11591             dxoijk=0.0D0
11592             do l=1,3
11593               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11594             enddo
11595             dxdv(k+3,ind1+1)=dxoijk
11596           enddo
11597         enddo
11598       enddo
11599 !
11600 ! Derivatives in alpha and omega:
11601 !
11602       do i=2,nres-1
11603 !       dsci=dsc(itype(i,1))
11604         dsci=vbld(i+nres)
11605 #ifdef OSF
11606         alphi=alph(i)
11607         omegi=omeg(i)
11608         if(alphi.ne.alphi) alphi=100.0
11609         if(omegi.ne.omegi) omegi=-100.0
11610 #else
11611       alphi=alph(i)
11612       omegi=omeg(i)
11613 #endif
11614 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
11615       cosalphi=dcos(alphi)
11616       sinalphi=dsin(alphi)
11617       cosomegi=dcos(omegi)
11618       sinomegi=dsin(omegi)
11619       temp(1,1)=-dsci*sinalphi
11620       temp(2,1)= dsci*cosalphi*cosomegi
11621       temp(3,1)=-dsci*cosalphi*sinomegi
11622       temp(1,2)=0.0D0
11623       temp(2,2)=-dsci*sinalphi*sinomegi
11624       temp(3,2)=-dsci*sinalphi*cosomegi
11625       theta2=pi-0.5D0*theta(i+1)
11626       cost2=dcos(theta2)
11627       sint2=dsin(theta2)
11628       jjj=0
11629 !d      print *,((temp(l,k),l=1,3),k=1,2)
11630         do j=1,2
11631         xp=temp(1,j)
11632         yp=temp(2,j)
11633         xxp= xp*cost2+yp*sint2
11634         yyp=-xp*sint2+yp*cost2
11635         zzp=temp(3,j)
11636         xx(1)=xxp
11637         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
11638         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
11639         do k=1,3
11640           dj=0.0D0
11641           do l=1,3
11642             dj=dj+prod(k,l,i-1)*xx(l)
11643             enddo
11644           dxds(jjj+k,i)=dj
11645           enddo
11646         jjj=jjj+3
11647       enddo
11648       enddo
11649       return
11650       end subroutine cartder
11651 !-----------------------------------------------------------------------------
11652 ! checkder_p.F
11653 !-----------------------------------------------------------------------------
11654       subroutine check_cartgrad
11655 ! Check the gradient of Cartesian coordinates in internal coordinates.
11656 !      implicit real*8 (a-h,o-z)
11657 !      include 'DIMENSIONS'
11658 !      include 'COMMON.IOUNITS'
11659 !      include 'COMMON.VAR'
11660 !      include 'COMMON.CHAIN'
11661 !      include 'COMMON.GEO'
11662 !      include 'COMMON.LOCAL'
11663 !      include 'COMMON.DERIV'
11664       real(kind=8),dimension(6,nres) :: temp
11665       real(kind=8),dimension(3) :: xx,gg
11666       integer :: i,k,j,ii
11667       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
11668 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11669 !
11670 ! Check the gradient of the virtual-bond and SC vectors in the internal
11671 ! coordinates.
11672 !
11673       aincr=1.0d-6
11674       aincr2=5.0d-7
11675       call cartder
11676       write (iout,'(a)') '**************** dx/dalpha'
11677       write (iout,'(a)')
11678       do i=2,nres-1
11679       alphi=alph(i)
11680       alph(i)=alph(i)+aincr
11681       do k=1,3
11682         temp(k,i)=dc(k,nres+i)
11683         enddo
11684       call chainbuild
11685       do k=1,3
11686         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11687         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11688         enddo
11689         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11690         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11691         write (iout,'(a)')
11692       alph(i)=alphi
11693       call chainbuild
11694       enddo
11695       write (iout,'(a)')
11696       write (iout,'(a)') '**************** dx/domega'
11697       write (iout,'(a)')
11698       do i=2,nres-1
11699       omegi=omeg(i)
11700       omeg(i)=omeg(i)+aincr
11701       do k=1,3
11702         temp(k,i)=dc(k,nres+i)
11703         enddo
11704       call chainbuild
11705       do k=1,3
11706           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11707           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11708                 (aincr*dabs(dxds(k+3,i))+aincr))
11709         enddo
11710         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11711             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11712         write (iout,'(a)')
11713       omeg(i)=omegi
11714       call chainbuild
11715       enddo
11716       write (iout,'(a)')
11717       write (iout,'(a)') '**************** dx/dtheta'
11718       write (iout,'(a)')
11719       do i=3,nres
11720       theti=theta(i)
11721         theta(i)=theta(i)+aincr
11722         do j=i-1,nres-1
11723           do k=1,3
11724             temp(k,j)=dc(k,nres+j)
11725           enddo
11726         enddo
11727         call chainbuild
11728         do j=i-1,nres-1
11729         ii = indmat(i-2,j)
11730 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11731         do k=1,3
11732           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11733           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11734                   (aincr*dabs(dxdv(k,ii))+aincr))
11735           enddo
11736           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11737               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11738           write(iout,'(a)')
11739         enddo
11740         write (iout,'(a)')
11741         theta(i)=theti
11742         call chainbuild
11743       enddo
11744       write (iout,'(a)') '***************** dx/dphi'
11745       write (iout,'(a)')
11746       do i=4,nres
11747         phi(i)=phi(i)+aincr
11748         do j=i-1,nres-1
11749           do k=1,3
11750             temp(k,j)=dc(k,nres+j)
11751           enddo
11752         enddo
11753         call chainbuild
11754         do j=i-1,nres-1
11755         ii = indmat(i-2,j)
11756 !         print *,'ii=',ii
11757         do k=1,3
11758           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11759             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
11760                   (aincr*dabs(dxdv(k+3,ii))+aincr))
11761           enddo
11762           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11763               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11764           write(iout,'(a)')
11765         enddo
11766         phi(i)=phi(i)-aincr
11767         call chainbuild
11768       enddo
11769       write (iout,'(a)') '****************** ddc/dtheta'
11770       do i=1,nres-2
11771         thet=theta(i+2)
11772         theta(i+2)=thet+aincr
11773         do j=i,nres
11774           do k=1,3
11775             temp(k,j)=dc(k,j)
11776           enddo
11777         enddo
11778         call chainbuild
11779         do j=i+1,nres-1
11780         ii = indmat(i,j)
11781 !         print *,'ii=',ii
11782         do k=1,3
11783           gg(k)=(dc(k,j)-temp(k,j))/aincr
11784           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11785                  (aincr*dabs(dcdv(k,ii))+aincr))
11786           enddo
11787           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11788                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11789         write (iout,'(a)')
11790         enddo
11791         do j=1,nres
11792           do k=1,3
11793             dc(k,j)=temp(k,j)
11794           enddo
11795         enddo
11796         theta(i+2)=thet
11797       enddo
11798       write (iout,'(a)') '******************* ddc/dphi'
11799       do i=1,nres-3
11800         phii=phi(i+3)
11801         phi(i+3)=phii+aincr
11802         do j=1,nres
11803           do k=1,3
11804             temp(k,j)=dc(k,j)
11805           enddo
11806         enddo
11807         call chainbuild
11808         do j=i+2,nres-1
11809         ii = indmat(i+1,j)
11810 !         print *,'ii=',ii
11811         do k=1,3
11812           gg(k)=(dc(k,j)-temp(k,j))/aincr
11813             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11814                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11815           enddo
11816           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11817                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11818         write (iout,'(a)')
11819         enddo
11820         do j=1,nres
11821           do k=1,3
11822             dc(k,j)=temp(k,j)
11823           enddo
11824         enddo
11825         phi(i+3)=phii
11826       enddo
11827       return
11828       end subroutine check_cartgrad
11829 !-----------------------------------------------------------------------------
11830       subroutine check_ecart
11831 ! Check the gradient of the energy in Cartesian coordinates.
11832 !     implicit real*8 (a-h,o-z)
11833 !     include 'DIMENSIONS'
11834 !     include 'COMMON.CHAIN'
11835 !     include 'COMMON.DERIV'
11836 !     include 'COMMON.IOUNITS'
11837 !     include 'COMMON.VAR'
11838 !     include 'COMMON.CONTACTS'
11839       use comm_srutu
11840 !el      integer :: icall
11841 !el      common /srutu/ icall
11842       real(kind=8),dimension(6) :: ggg
11843       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11844       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11845       real(kind=8),dimension(6,nres) :: grad_s
11846       real(kind=8),dimension(0:n_ene) :: energia,energia1
11847       integer :: uiparm(1)
11848       real(kind=8) :: urparm(1)
11849 !EL      external fdum
11850       integer :: nf,i,j,k
11851       real(kind=8) :: aincr,etot,etot1
11852       icg=1
11853       nf=0
11854       nfl=0
11855       call zerograd
11856       aincr=1.0D-5
11857       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11858       nf=0
11859       icall=0
11860       call geom_to_var(nvar,x)
11861       call etotal(energia)
11862       etot=energia(0)
11863 !el      call enerprint(energia)
11864       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11865       icall =1
11866       do i=1,nres
11867         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11868       enddo
11869       do i=1,nres
11870       do j=1,3
11871         grad_s(j,i)=gradc(j,i,icg)
11872         grad_s(j+3,i)=gradx(j,i,icg)
11873         enddo
11874       enddo
11875       call flush(iout)
11876       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11877       do i=1,nres
11878         do j=1,3
11879         xx(j)=c(j,i+nres)
11880         ddc(j)=dc(j,i)
11881         ddx(j)=dc(j,i+nres)
11882         enddo
11883       do j=1,3
11884         dc(j,i)=dc(j,i)+aincr
11885         do k=i+1,nres
11886           c(j,k)=c(j,k)+aincr
11887           c(j,k+nres)=c(j,k+nres)+aincr
11888           enddo
11889           call zerograd
11890           call etotal(energia1)
11891           etot1=energia1(0)
11892         ggg(j)=(etot1-etot)/aincr
11893         dc(j,i)=ddc(j)
11894         do k=i+1,nres
11895           c(j,k)=c(j,k)-aincr
11896           c(j,k+nres)=c(j,k+nres)-aincr
11897           enddo
11898         enddo
11899       do j=1,3
11900         c(j,i+nres)=c(j,i+nres)+aincr
11901         dc(j,i+nres)=dc(j,i+nres)+aincr
11902           call zerograd
11903           call etotal(energia1)
11904           etot1=energia1(0)
11905         ggg(j+3)=(etot1-etot)/aincr
11906         c(j,i+nres)=xx(j)
11907         dc(j,i+nres)=ddx(j)
11908         enddo
11909       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11910          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11911       enddo
11912       return
11913       end subroutine check_ecart
11914 #ifdef CARGRAD
11915 !-----------------------------------------------------------------------------
11916       subroutine check_ecartint
11917 ! Check the gradient of the energy in Cartesian coordinates.
11918       use io_base, only: intout
11919 !      implicit real*8 (a-h,o-z)
11920 !      include 'DIMENSIONS'
11921 !      include 'COMMON.CONTROL'
11922 !      include 'COMMON.CHAIN'
11923 !      include 'COMMON.DERIV'
11924 !      include 'COMMON.IOUNITS'
11925 !      include 'COMMON.VAR'
11926 !      include 'COMMON.CONTACTS'
11927 !      include 'COMMON.MD'
11928 !      include 'COMMON.LOCAL'
11929 !      include 'COMMON.SPLITELE'
11930       use comm_srutu
11931 !el      integer :: icall
11932 !el      common /srutu/ icall
11933       real(kind=8),dimension(6) :: ggg,ggg1
11934       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11935       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11936       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11937       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11938       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11939       real(kind=8),dimension(0:n_ene) :: energia,energia1
11940       integer :: uiparm(1)
11941       real(kind=8) :: urparm(1)
11942 !EL      external fdum
11943       integer :: i,j,k,nf
11944       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11945                    etot21,etot22
11946       r_cut=2.0d0
11947       rlambd=0.3d0
11948       icg=1
11949       nf=0
11950       nfl=0
11951       call intout
11952 !      call intcartderiv
11953 !      call checkintcartgrad
11954       call zerograd
11955       aincr=1.0D-4
11956       write(iout,*) 'Calling CHECK_ECARTINT.'
11957       nf=0
11958       icall=0
11959       call geom_to_var(nvar,x)
11960       write (iout,*) "split_ene ",split_ene
11961       call flush(iout)
11962       if (.not.split_ene) then
11963         call zerograd
11964         call etotal(energia)
11965         etot=energia(0)
11966         call cartgrad
11967         icall =1
11968         do i=1,nres
11969           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11970         enddo
11971         do j=1,3
11972           grad_s(j,0)=gcart(j,0)
11973         enddo
11974         do i=1,nres
11975           do j=1,3
11976             grad_s(j,i)=gcart(j,i)
11977             grad_s(j+3,i)=gxcart(j,i)
11978           enddo
11979         enddo
11980       else
11981 !- split gradient check
11982         call zerograd
11983         call etotal_long(energia)
11984 !el        call enerprint(energia)
11985         call cartgrad
11986         icall =1
11987         do i=1,nres
11988           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11989           (gxcart(j,i),j=1,3)
11990         enddo
11991         do j=1,3
11992           grad_s(j,0)=gcart(j,0)
11993         enddo
11994         do i=1,nres
11995           do j=1,3
11996             grad_s(j,i)=gcart(j,i)
11997             grad_s(j+3,i)=gxcart(j,i)
11998           enddo
11999         enddo
12000         call zerograd
12001         call etotal_short(energia)
12002         call enerprint(energia)
12003         call cartgrad
12004         icall =1
12005         do i=1,nres
12006           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12007           (gxcart(j,i),j=1,3)
12008         enddo
12009         do j=1,3
12010           grad_s1(j,0)=gcart(j,0)
12011         enddo
12012         do i=1,nres
12013           do j=1,3
12014             grad_s1(j,i)=gcart(j,i)
12015             grad_s1(j+3,i)=gxcart(j,i)
12016           enddo
12017         enddo
12018       endif
12019       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12020 !      do i=1,nres
12021       do i=nnt,nct
12022         do j=1,3
12023           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
12024           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
12025         ddc(j)=c(j,i)
12026         ddx(j)=c(j,i+nres)
12027           dcnorm_safe1(j)=dc_norm(j,i-1)
12028           dcnorm_safe2(j)=dc_norm(j,i)
12029           dxnorm_safe(j)=dc_norm(j,i+nres)
12030         enddo
12031       do j=1,3
12032         c(j,i)=ddc(j)+aincr
12033           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
12034           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
12035           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12036           dc(j,i)=c(j,i+1)-c(j,i)
12037           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12038           call int_from_cart1(.false.)
12039           if (.not.split_ene) then
12040            call zerograd
12041             call etotal(energia1)
12042             etot1=energia1(0)
12043             write (iout,*) "ij",i,j," etot1",etot1
12044           else
12045 !- split gradient
12046             call etotal_long(energia1)
12047             etot11=energia1(0)
12048             call etotal_short(energia1)
12049             etot12=energia1(0)
12050           endif
12051 !- end split gradient
12052 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12053         c(j,i)=ddc(j)-aincr
12054           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
12055           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
12056           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12057           dc(j,i)=c(j,i+1)-c(j,i)
12058           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12059           call int_from_cart1(.false.)
12060           if (.not.split_ene) then
12061             call zerograd
12062             call etotal(energia1)
12063             etot2=energia1(0)
12064             write (iout,*) "ij",i,j," etot2",etot2
12065           ggg(j)=(etot1-etot2)/(2*aincr)
12066           else
12067 !- split gradient
12068             call etotal_long(energia1)
12069             etot21=energia1(0)
12070           ggg(j)=(etot11-etot21)/(2*aincr)
12071             call etotal_short(energia1)
12072             etot22=energia1(0)
12073           ggg1(j)=(etot12-etot22)/(2*aincr)
12074 !- end split gradient
12075 !            write (iout,*) "etot21",etot21," etot22",etot22
12076           endif
12077 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12078         c(j,i)=ddc(j)
12079           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
12080           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
12081           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12082           dc(j,i)=c(j,i+1)-c(j,i)
12083           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12084           dc_norm(j,i-1)=dcnorm_safe1(j)
12085           dc_norm(j,i)=dcnorm_safe2(j)
12086           dc_norm(j,i+nres)=dxnorm_safe(j)
12087         enddo
12088       do j=1,3
12089         c(j,i+nres)=ddx(j)+aincr
12090           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12091           call int_from_cart1(.false.)
12092           if (.not.split_ene) then
12093             call zerograd
12094             call etotal(energia1)
12095             etot1=energia1(0)
12096           else
12097 !- split gradient
12098             call etotal_long(energia1)
12099             etot11=energia1(0)
12100             call etotal_short(energia1)
12101             etot12=energia1(0)
12102           endif
12103 !- end split gradient
12104         c(j,i+nres)=ddx(j)-aincr
12105           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12106           call int_from_cart1(.false.)
12107           if (.not.split_ene) then
12108            call zerograd
12109            call etotal(energia1)
12110             etot2=energia1(0)
12111           ggg(j+3)=(etot1-etot2)/(2*aincr)
12112           else
12113 !- split gradient
12114             call etotal_long(energia1)
12115             etot21=energia1(0)
12116           ggg(j+3)=(etot11-etot21)/(2*aincr)
12117             call etotal_short(energia1)
12118             etot22=energia1(0)
12119           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12120 !- end split gradient
12121           endif
12122 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12123         c(j,i+nres)=ddx(j)
12124           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12125           dc_norm(j,i+nres)=dxnorm_safe(j)
12126           call int_from_cart1(.false.)
12127         enddo
12128       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12129          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12130         if (split_ene) then
12131           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12132          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12133          k=1,6)
12134          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12135          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12136          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12137         endif
12138       enddo
12139       return
12140       end subroutine check_ecartint
12141 #else
12142 !-----------------------------------------------------------------------------
12143       subroutine check_ecartint
12144 ! Check the gradient of the energy in Cartesian coordinates.
12145       use io_base, only: intout
12146 !      implicit real*8 (a-h,o-z)
12147 !      include 'DIMENSIONS'
12148 !      include 'COMMON.CONTROL'
12149 !      include 'COMMON.CHAIN'
12150 !      include 'COMMON.DERIV'
12151 !      include 'COMMON.IOUNITS'
12152 !      include 'COMMON.VAR'
12153 !      include 'COMMON.CONTACTS'
12154 !      include 'COMMON.MD'
12155 !      include 'COMMON.LOCAL'
12156 !      include 'COMMON.SPLITELE'
12157       use comm_srutu
12158 !el      integer :: icall
12159 !el      common /srutu/ icall
12160       real(kind=8),dimension(6) :: ggg,ggg1
12161       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12162       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12163       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12164       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12165       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12166       real(kind=8),dimension(0:n_ene) :: energia,energia1
12167       integer :: uiparm(1)
12168       real(kind=8) :: urparm(1)
12169 !EL      external fdum
12170       integer :: i,j,k,nf
12171       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12172                    etot21,etot22
12173       r_cut=2.0d0
12174       rlambd=0.3d0
12175       icg=1
12176       nf=0
12177       nfl=0
12178       call intout
12179 !      call intcartderiv
12180 !      call checkintcartgrad
12181       call zerograd
12182       aincr=2.0D-5
12183       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12184       nf=0
12185       icall=0
12186       call geom_to_var(nvar,x)
12187       if (.not.split_ene) then
12188         call etotal(energia)
12189         etot=energia(0)
12190 !el        call enerprint(energia)
12191         call cartgrad
12192         icall =1
12193         do i=1,nres
12194           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12195         enddo
12196         do j=1,3
12197           grad_s(j,0)=gcart(j,0)
12198         enddo
12199         do i=1,nres
12200           do j=1,3
12201             grad_s(j,i)=gcart(j,i)
12202 !              if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12203
12204 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12205             grad_s(j+3,i)=gxcart(j,i)
12206           enddo
12207         enddo
12208       else
12209 !- split gradient check
12210         call zerograd
12211         call etotal_long(energia)
12212 !el        call enerprint(energia)
12213         call cartgrad
12214         icall =1
12215         do i=1,nres
12216           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12217           (gxcart(j,i),j=1,3)
12218         enddo
12219         do j=1,3
12220           grad_s(j,0)=gcart(j,0)
12221         enddo
12222         do i=1,nres
12223           do j=1,3
12224             grad_s(j,i)=gcart(j,i)
12225 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12226             grad_s(j+3,i)=gxcart(j,i)
12227           enddo
12228         enddo
12229         call zerograd
12230         call etotal_short(energia)
12231 !el        call enerprint(energia)
12232         call cartgrad
12233         icall =1
12234         do i=1,nres
12235           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12236           (gxcart(j,i),j=1,3)
12237         enddo
12238         do j=1,3
12239           grad_s1(j,0)=gcart(j,0)
12240         enddo
12241         do i=1,nres
12242           do j=1,3
12243             grad_s1(j,i)=gcart(j,i)
12244             grad_s1(j+3,i)=gxcart(j,i)
12245           enddo
12246         enddo
12247       endif
12248       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12249       do i=0,nres
12250         do j=1,3
12251         xx(j)=c(j,i+nres)
12252         ddc(j)=dc(j,i)
12253         ddx(j)=dc(j,i+nres)
12254           do k=1,3
12255             dcnorm_safe(k)=dc_norm(k,i)
12256             dxnorm_safe(k)=dc_norm(k,i+nres)
12257           enddo
12258         enddo
12259       do j=1,3
12260         dc(j,i)=ddc(j)+aincr
12261           call chainbuild_cart
12262 #ifdef MPI
12263 ! Broadcast the order to compute internal coordinates to the slaves.
12264 !          if (nfgtasks.gt.1)
12265 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12266 #endif
12267 !          call int_from_cart1(.false.)
12268           if (.not.split_ene) then
12269            call zerograd
12270             call etotal(energia1)
12271             etot1=energia1(0)
12272 !            call enerprint(energia1)
12273           else
12274 !- split gradient
12275             call etotal_long(energia1)
12276             etot11=energia1(0)
12277             call etotal_short(energia1)
12278             etot12=energia1(0)
12279 !            write (iout,*) "etot11",etot11," etot12",etot12
12280           endif
12281 !- end split gradient
12282 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12283         dc(j,i)=ddc(j)-aincr
12284           call chainbuild_cart
12285 !          call int_from_cart1(.false.)
12286           if (.not.split_ene) then
12287                   call zerograd
12288             call etotal(energia1)
12289             etot2=energia1(0)
12290           ggg(j)=(etot1-etot2)/(2*aincr)
12291           else
12292 !- split gradient
12293             call etotal_long(energia1)
12294             etot21=energia1(0)
12295           ggg(j)=(etot11-etot21)/(2*aincr)
12296             call etotal_short(energia1)
12297             etot22=energia1(0)
12298           ggg1(j)=(etot12-etot22)/(2*aincr)
12299 !- end split gradient
12300 !            write (iout,*) "etot21",etot21," etot22",etot22
12301           endif
12302 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12303         dc(j,i)=ddc(j)
12304           call chainbuild_cart
12305         enddo
12306       do j=1,3
12307         dc(j,i+nres)=ddx(j)+aincr
12308           call chainbuild_cart
12309 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12310 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12311 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12312 !          write (iout,*) "dxnormnorm",dsqrt(
12313 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12314 !          write (iout,*) "dxnormnormsafe",dsqrt(
12315 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12316 !          write (iout,*)
12317           if (.not.split_ene) then
12318             call zerograd
12319             call etotal(energia1)
12320             etot1=energia1(0)
12321           else
12322 !- split gradient
12323             call etotal_long(energia1)
12324             etot11=energia1(0)
12325             call etotal_short(energia1)
12326             etot12=energia1(0)
12327           endif
12328 !- end split gradient
12329 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12330         dc(j,i+nres)=ddx(j)-aincr
12331           call chainbuild_cart
12332 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12333 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12334 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12335 !          write (iout,*)
12336 !          write (iout,*) "dxnormnorm",dsqrt(
12337 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12338 !          write (iout,*) "dxnormnormsafe",dsqrt(
12339 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12340           if (.not.split_ene) then
12341             call zerograd
12342             call etotal(energia1)
12343             etot2=energia1(0)
12344           ggg(j+3)=(etot1-etot2)/(2*aincr)
12345           else
12346 !- split gradient
12347             call etotal_long(energia1)
12348             etot21=energia1(0)
12349           ggg(j+3)=(etot11-etot21)/(2*aincr)
12350             call etotal_short(energia1)
12351             etot22=energia1(0)
12352           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12353 !- end split gradient
12354           endif
12355 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12356         dc(j,i+nres)=ddx(j)
12357           call chainbuild_cart
12358         enddo
12359       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12360          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12361         if (split_ene) then
12362           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12363          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12364          k=1,6)
12365          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12366          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12367          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12368         endif
12369       enddo
12370       return
12371       end subroutine check_ecartint
12372 #endif
12373 !-----------------------------------------------------------------------------
12374       subroutine check_eint
12375 ! Check the gradient of energy in internal coordinates.
12376 !      implicit real*8 (a-h,o-z)
12377 !      include 'DIMENSIONS'
12378 !      include 'COMMON.CHAIN'
12379 !      include 'COMMON.DERIV'
12380 !      include 'COMMON.IOUNITS'
12381 !      include 'COMMON.VAR'
12382 !      include 'COMMON.GEO'
12383       use comm_srutu
12384 !el      integer :: icall
12385 !el      common /srutu/ icall
12386       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12387       integer :: uiparm(1)
12388       real(kind=8) :: urparm(1)
12389       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12390       character(len=6) :: key
12391 !EL      external fdum
12392       integer :: i,ii,nf
12393       real(kind=8) :: xi,aincr,etot,etot1,etot2
12394       call zerograd
12395       aincr=1.0D-7
12396       print '(a)','Calling CHECK_INT.'
12397       nf=0
12398       nfl=0
12399       icg=1
12400       call geom_to_var(nvar,x)
12401       call var_to_geom(nvar,x)
12402       call chainbuild
12403       icall=1
12404 !      print *,'ICG=',ICG
12405       call etotal(energia)
12406       etot = energia(0)
12407 !el      call enerprint(energia)
12408 !      print *,'ICG=',ICG
12409 #ifdef MPL
12410       if (MyID.ne.BossID) then
12411         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12412         nf=x(nvar+1)
12413         nfl=x(nvar+2)
12414         icg=x(nvar+3)
12415       endif
12416 #endif
12417       nf=1
12418       nfl=3
12419 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12420       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12421 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12422       icall=1
12423       do i=1,nvar
12424         xi=x(i)
12425         x(i)=xi-0.5D0*aincr
12426         call var_to_geom(nvar,x)
12427         call chainbuild
12428         call etotal(energia1)
12429         etot1=energia1(0)
12430         x(i)=xi+0.5D0*aincr
12431         call var_to_geom(nvar,x)
12432         call chainbuild
12433         call etotal(energia2)
12434         etot2=energia2(0)
12435         gg(i)=(etot2-etot1)/aincr
12436         write (iout,*) i,etot1,etot2
12437         x(i)=xi
12438       enddo
12439       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
12440           '     RelDiff*100% '
12441       do i=1,nvar
12442         if (i.le.nphi) then
12443           ii=i
12444           key = ' phi'
12445         else if (i.le.nphi+ntheta) then
12446           ii=i-nphi
12447           key=' theta'
12448         else if (i.le.nphi+ntheta+nside) then
12449            ii=i-(nphi+ntheta)
12450            key=' alpha'
12451         else
12452            ii=i-(nphi+ntheta+nside)
12453            key=' omega'
12454         endif
12455         write (iout,'(i3,a,i3,3(1pd16.6))') &
12456        i,key,ii,gg(i),gana(i),&
12457        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
12458       enddo
12459       return
12460       end subroutine check_eint
12461 !-----------------------------------------------------------------------------
12462 ! econstr_local.F
12463 !-----------------------------------------------------------------------------
12464       subroutine Econstr_back
12465 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
12466 !      implicit real*8 (a-h,o-z)
12467 !      include 'DIMENSIONS'
12468 !      include 'COMMON.CONTROL'
12469 !      include 'COMMON.VAR'
12470 !      include 'COMMON.MD'
12471       use MD_data
12472 !#ifndef LANG0
12473 !      include 'COMMON.LANGEVIN'
12474 !#else
12475 !      include 'COMMON.LANGEVIN.lang0'
12476 !#endif
12477 !      include 'COMMON.CHAIN'
12478 !      include 'COMMON.DERIV'
12479 !      include 'COMMON.GEO'
12480 !      include 'COMMON.LOCAL'
12481 !      include 'COMMON.INTERACT'
12482 !      include 'COMMON.IOUNITS'
12483 !      include 'COMMON.NAMES'
12484 !      include 'COMMON.TIME1'
12485       integer :: i,j,ii,k
12486       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
12487
12488       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
12489       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
12490       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
12491
12492       Uconst_back=0.0d0
12493       do i=1,nres
12494         dutheta(i)=0.0d0
12495         dugamma(i)=0.0d0
12496         do j=1,3
12497           duscdiff(j,i)=0.0d0
12498           duscdiffx(j,i)=0.0d0
12499         enddo
12500       enddo
12501       do i=1,nfrag_back
12502         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
12503 !
12504 ! Deviations from theta angles
12505 !
12506         utheta_i=0.0d0
12507         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
12508           dtheta_i=theta(j)-thetaref(j)
12509           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
12510           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
12511         enddo
12512         utheta(i)=utheta_i/(ii-1)
12513 !
12514 ! Deviations from gamma angles
12515 !
12516         ugamma_i=0.0d0
12517         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
12518           dgamma_i=pinorm(phi(j)-phiref(j))
12519 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
12520           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
12521           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
12522 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
12523         enddo
12524         ugamma(i)=ugamma_i/(ii-2)
12525 !
12526 ! Deviations from local SC geometry
12527 !
12528         uscdiff(i)=0.0d0
12529         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
12530           dxx=xxtab(j)-xxref(j)
12531           dyy=yytab(j)-yyref(j)
12532           dzz=zztab(j)-zzref(j)
12533           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
12534           do k=1,3
12535             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
12536              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
12537              (ii-1)
12538             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
12539              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
12540              (ii-1)
12541             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
12542            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
12543             /(ii-1)
12544           enddo
12545 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
12546 !     &      xxref(j),yyref(j),zzref(j)
12547         enddo
12548         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
12549 !        write (iout,*) i," uscdiff",uscdiff(i)
12550 !
12551 ! Put together deviations from local geometry
12552 !
12553         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
12554           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
12555 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
12556 !     &   " uconst_back",uconst_back
12557         utheta(i)=dsqrt(utheta(i))
12558         ugamma(i)=dsqrt(ugamma(i))
12559         uscdiff(i)=dsqrt(uscdiff(i))
12560       enddo
12561       return
12562       end subroutine Econstr_back
12563 !-----------------------------------------------------------------------------
12564 ! energy_p_new-sep_barrier.F
12565 !-----------------------------------------------------------------------------
12566       real(kind=8) function sscale(r)
12567 !      include "COMMON.SPLITELE"
12568       real(kind=8) :: r,gamm
12569       if(r.lt.r_cut-rlamb) then
12570         sscale=1.0d0
12571       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12572         gamm=(r-(r_cut-rlamb))/rlamb
12573         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12574       else
12575         sscale=0d0
12576       endif
12577       return
12578       end function sscale
12579       real(kind=8) function sscale_grad(r)
12580 !      include "COMMON.SPLITELE"
12581       real(kind=8) :: r,gamm
12582       if(r.lt.r_cut-rlamb) then
12583         sscale_grad=0.0d0
12584       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12585         gamm=(r-(r_cut-rlamb))/rlamb
12586         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
12587       else
12588         sscale_grad=0d0
12589       endif
12590       return
12591       end function sscale_grad
12592
12593 !!!!!!!!!! PBCSCALE
12594       real(kind=8) function sscale_ele(r)
12595 !      include "COMMON.SPLITELE"
12596       real(kind=8) :: r,gamm
12597       if(r.lt.r_cut_ele-rlamb_ele) then
12598         sscale_ele=1.0d0
12599       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12600         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12601         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12602       else
12603         sscale_ele=0d0
12604       endif
12605       return
12606       end function sscale_ele
12607
12608       real(kind=8)  function sscagrad_ele(r)
12609       real(kind=8) :: r,gamm
12610 !      include "COMMON.SPLITELE"
12611       if(r.lt.r_cut_ele-rlamb_ele) then
12612         sscagrad_ele=0.0d0
12613       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12614         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12615         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
12616       else
12617         sscagrad_ele=0.0d0
12618       endif
12619       return
12620       end function sscagrad_ele
12621       real(kind=8) function sscalelip(r)
12622       real(kind=8) r,gamm
12623         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
12624       return
12625       end function sscalelip
12626 !C-----------------------------------------------------------------------
12627       real(kind=8) function sscagradlip(r)
12628       real(kind=8) r,gamm
12629         sscagradlip=r*(6.0d0*r-6.0d0)
12630       return
12631       end function sscagradlip
12632
12633 !!!!!!!!!!!!!!!
12634 !-----------------------------------------------------------------------------
12635       subroutine elj_long(evdw)
12636 !
12637 ! This subroutine calculates the interaction energy of nonbonded side chains
12638 ! assuming the LJ potential of interaction.
12639 !
12640 !      implicit real*8 (a-h,o-z)
12641 !      include 'DIMENSIONS'
12642 !      include 'COMMON.GEO'
12643 !      include 'COMMON.VAR'
12644 !      include 'COMMON.LOCAL'
12645 !      include 'COMMON.CHAIN'
12646 !      include 'COMMON.DERIV'
12647 !      include 'COMMON.INTERACT'
12648 !      include 'COMMON.TORSION'
12649 !      include 'COMMON.SBRIDGE'
12650 !      include 'COMMON.NAMES'
12651 !      include 'COMMON.IOUNITS'
12652 !      include 'COMMON.CONTACTS'
12653       real(kind=8),parameter :: accur=1.0d-10
12654       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12655 !el local variables
12656       integer :: i,iint,j,k,itypi,itypi1,itypj
12657       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12658       real(kind=8) :: e1,e2,evdwij,evdw
12659 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12660       evdw=0.0D0
12661       do i=iatsc_s,iatsc_e
12662         itypi=itype(i,1)
12663         if (itypi.eq.ntyp1) cycle
12664         itypi1=itype(i+1,1)
12665         xi=c(1,nres+i)
12666         yi=c(2,nres+i)
12667         zi=c(3,nres+i)
12668 !
12669 ! Calculate SC interaction energy.
12670 !
12671         do iint=1,nint_gr(i)
12672 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12673 !d   &                  'iend=',iend(i,iint)
12674           do j=istart(i,iint),iend(i,iint)
12675             itypj=itype(j,1)
12676             if (itypj.eq.ntyp1) cycle
12677             xj=c(1,nres+j)-xi
12678             yj=c(2,nres+j)-yi
12679             zj=c(3,nres+j)-zi
12680             rij=xj*xj+yj*yj+zj*zj
12681             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12682             if (sss.lt.1.0d0) then
12683               rrij=1.0D0/rij
12684               eps0ij=eps(itypi,itypj)
12685               fac=rrij**expon2
12686               e1=fac*fac*aa_aq(itypi,itypj)
12687               e2=fac*bb_aq(itypi,itypj)
12688               evdwij=e1+e2
12689               evdw=evdw+(1.0d0-sss)*evdwij
12690 !
12691 ! Calculate the components of the gradient in DC and X
12692 !
12693               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12694               gg(1)=xj*fac
12695               gg(2)=yj*fac
12696               gg(3)=zj*fac
12697               do k=1,3
12698                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12699                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12700                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12701                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12702               enddo
12703             endif
12704           enddo      ! j
12705         enddo        ! iint
12706       enddo          ! i
12707       do i=1,nct
12708         do j=1,3
12709           gvdwc(j,i)=expon*gvdwc(j,i)
12710           gvdwx(j,i)=expon*gvdwx(j,i)
12711         enddo
12712       enddo
12713 !******************************************************************************
12714 !
12715 !                              N O T E !!!
12716 !
12717 ! To save time, the factor of EXPON has been extracted from ALL components
12718 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12719 ! use!
12720 !
12721 !******************************************************************************
12722       return
12723       end subroutine elj_long
12724 !-----------------------------------------------------------------------------
12725       subroutine elj_short(evdw)
12726 !
12727 ! This subroutine calculates the interaction energy of nonbonded side chains
12728 ! assuming the LJ potential of interaction.
12729 !
12730 !      implicit real*8 (a-h,o-z)
12731 !      include 'DIMENSIONS'
12732 !      include 'COMMON.GEO'
12733 !      include 'COMMON.VAR'
12734 !      include 'COMMON.LOCAL'
12735 !      include 'COMMON.CHAIN'
12736 !      include 'COMMON.DERIV'
12737 !      include 'COMMON.INTERACT'
12738 !      include 'COMMON.TORSION'
12739 !      include 'COMMON.SBRIDGE'
12740 !      include 'COMMON.NAMES'
12741 !      include 'COMMON.IOUNITS'
12742 !      include 'COMMON.CONTACTS'
12743       real(kind=8),parameter :: accur=1.0d-10
12744       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12745 !el local variables
12746       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12747       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12748       real(kind=8) :: e1,e2,evdwij,evdw
12749 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12750       evdw=0.0D0
12751       do i=iatsc_s,iatsc_e
12752         itypi=itype(i,1)
12753         if (itypi.eq.ntyp1) cycle
12754         itypi1=itype(i+1,1)
12755         xi=c(1,nres+i)
12756         yi=c(2,nres+i)
12757         zi=c(3,nres+i)
12758 ! Change 12/1/95
12759         num_conti=0
12760 !
12761 ! Calculate SC interaction energy.
12762 !
12763         do iint=1,nint_gr(i)
12764 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12765 !d   &                  'iend=',iend(i,iint)
12766           do j=istart(i,iint),iend(i,iint)
12767             itypj=itype(j,1)
12768             if (itypj.eq.ntyp1) cycle
12769             xj=c(1,nres+j)-xi
12770             yj=c(2,nres+j)-yi
12771             zj=c(3,nres+j)-zi
12772 ! Change 12/1/95 to calculate four-body interactions
12773             rij=xj*xj+yj*yj+zj*zj
12774             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12775             if (sss.gt.0.0d0) then
12776               rrij=1.0D0/rij
12777               eps0ij=eps(itypi,itypj)
12778               fac=rrij**expon2
12779               e1=fac*fac*aa_aq(itypi,itypj)
12780               e2=fac*bb_aq(itypi,itypj)
12781               evdwij=e1+e2
12782               evdw=evdw+sss*evdwij
12783 !
12784 ! Calculate the components of the gradient in DC and X
12785 !
12786               fac=-rrij*(e1+evdwij)*sss
12787               gg(1)=xj*fac
12788               gg(2)=yj*fac
12789               gg(3)=zj*fac
12790               do k=1,3
12791                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12792                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12793                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12794                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12795               enddo
12796             endif
12797           enddo      ! j
12798         enddo        ! iint
12799       enddo          ! i
12800       do i=1,nct
12801         do j=1,3
12802           gvdwc(j,i)=expon*gvdwc(j,i)
12803           gvdwx(j,i)=expon*gvdwx(j,i)
12804         enddo
12805       enddo
12806 !******************************************************************************
12807 !
12808 !                              N O T E !!!
12809 !
12810 ! To save time, the factor of EXPON has been extracted from ALL components
12811 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12812 ! use!
12813 !
12814 !******************************************************************************
12815       return
12816       end subroutine elj_short
12817 !-----------------------------------------------------------------------------
12818       subroutine eljk_long(evdw)
12819 !
12820 ! This subroutine calculates the interaction energy of nonbonded side chains
12821 ! assuming the LJK potential of interaction.
12822 !
12823 !      implicit real*8 (a-h,o-z)
12824 !      include 'DIMENSIONS'
12825 !      include 'COMMON.GEO'
12826 !      include 'COMMON.VAR'
12827 !      include 'COMMON.LOCAL'
12828 !      include 'COMMON.CHAIN'
12829 !      include 'COMMON.DERIV'
12830 !      include 'COMMON.INTERACT'
12831 !      include 'COMMON.IOUNITS'
12832 !      include 'COMMON.NAMES'
12833       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12834       logical :: scheck
12835 !el local variables
12836       integer :: i,iint,j,k,itypi,itypi1,itypj
12837       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12838                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12839 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12840       evdw=0.0D0
12841       do i=iatsc_s,iatsc_e
12842         itypi=itype(i,1)
12843         if (itypi.eq.ntyp1) cycle
12844         itypi1=itype(i+1,1)
12845         xi=c(1,nres+i)
12846         yi=c(2,nres+i)
12847         zi=c(3,nres+i)
12848 !
12849 ! Calculate SC interaction energy.
12850 !
12851         do iint=1,nint_gr(i)
12852           do j=istart(i,iint),iend(i,iint)
12853             itypj=itype(j,1)
12854             if (itypj.eq.ntyp1) cycle
12855             xj=c(1,nres+j)-xi
12856             yj=c(2,nres+j)-yi
12857             zj=c(3,nres+j)-zi
12858             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12859             fac_augm=rrij**expon
12860             e_augm=augm(itypi,itypj)*fac_augm
12861             r_inv_ij=dsqrt(rrij)
12862             rij=1.0D0/r_inv_ij
12863             sss=sscale(rij/sigma(itypi,itypj))
12864             if (sss.lt.1.0d0) then
12865               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12866               fac=r_shift_inv**expon
12867               e1=fac*fac*aa_aq(itypi,itypj)
12868               e2=fac*bb_aq(itypi,itypj)
12869               evdwij=e_augm+e1+e2
12870 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12871 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12872 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12873 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12874 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12875 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12876 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12877               evdw=evdw+(1.0d0-sss)*evdwij
12878 !
12879 ! Calculate the components of the gradient in DC and X
12880 !
12881               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12882               fac=fac*(1.0d0-sss)
12883               gg(1)=xj*fac
12884               gg(2)=yj*fac
12885               gg(3)=zj*fac
12886               do k=1,3
12887                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12888                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12889                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12890                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12891               enddo
12892             endif
12893           enddo      ! j
12894         enddo        ! iint
12895       enddo          ! i
12896       do i=1,nct
12897         do j=1,3
12898           gvdwc(j,i)=expon*gvdwc(j,i)
12899           gvdwx(j,i)=expon*gvdwx(j,i)
12900         enddo
12901       enddo
12902       return
12903       end subroutine eljk_long
12904 !-----------------------------------------------------------------------------
12905       subroutine eljk_short(evdw)
12906 !
12907 ! This subroutine calculates the interaction energy of nonbonded side chains
12908 ! assuming the LJK potential of interaction.
12909 !
12910 !      implicit real*8 (a-h,o-z)
12911 !      include 'DIMENSIONS'
12912 !      include 'COMMON.GEO'
12913 !      include 'COMMON.VAR'
12914 !      include 'COMMON.LOCAL'
12915 !      include 'COMMON.CHAIN'
12916 !      include 'COMMON.DERIV'
12917 !      include 'COMMON.INTERACT'
12918 !      include 'COMMON.IOUNITS'
12919 !      include 'COMMON.NAMES'
12920       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12921       logical :: scheck
12922 !el local variables
12923       integer :: i,iint,j,k,itypi,itypi1,itypj
12924       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12925                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12926 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12927       evdw=0.0D0
12928       do i=iatsc_s,iatsc_e
12929         itypi=itype(i,1)
12930         if (itypi.eq.ntyp1) cycle
12931         itypi1=itype(i+1,1)
12932         xi=c(1,nres+i)
12933         yi=c(2,nres+i)
12934         zi=c(3,nres+i)
12935 !
12936 ! Calculate SC interaction energy.
12937 !
12938         do iint=1,nint_gr(i)
12939           do j=istart(i,iint),iend(i,iint)
12940             itypj=itype(j,1)
12941             if (itypj.eq.ntyp1) cycle
12942             xj=c(1,nres+j)-xi
12943             yj=c(2,nres+j)-yi
12944             zj=c(3,nres+j)-zi
12945             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12946             fac_augm=rrij**expon
12947             e_augm=augm(itypi,itypj)*fac_augm
12948             r_inv_ij=dsqrt(rrij)
12949             rij=1.0D0/r_inv_ij
12950             sss=sscale(rij/sigma(itypi,itypj))
12951             if (sss.gt.0.0d0) then
12952               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12953               fac=r_shift_inv**expon
12954               e1=fac*fac*aa_aq(itypi,itypj)
12955               e2=fac*bb_aq(itypi,itypj)
12956               evdwij=e_augm+e1+e2
12957 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12958 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12959 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12960 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12961 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12962 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12963 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12964               evdw=evdw+sss*evdwij
12965 !
12966 ! Calculate the components of the gradient in DC and X
12967 !
12968               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12969               fac=fac*sss
12970               gg(1)=xj*fac
12971               gg(2)=yj*fac
12972               gg(3)=zj*fac
12973               do k=1,3
12974                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12975                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12976                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12977                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12978               enddo
12979             endif
12980           enddo      ! j
12981         enddo        ! iint
12982       enddo          ! i
12983       do i=1,nct
12984         do j=1,3
12985           gvdwc(j,i)=expon*gvdwc(j,i)
12986           gvdwx(j,i)=expon*gvdwx(j,i)
12987         enddo
12988       enddo
12989       return
12990       end subroutine eljk_short
12991 !-----------------------------------------------------------------------------
12992       subroutine ebp_long(evdw)
12993 !
12994 ! This subroutine calculates the interaction energy of nonbonded side chains
12995 ! assuming the Berne-Pechukas potential of interaction.
12996 !
12997       use calc_data
12998 !      implicit real*8 (a-h,o-z)
12999 !      include 'DIMENSIONS'
13000 !      include 'COMMON.GEO'
13001 !      include 'COMMON.VAR'
13002 !      include 'COMMON.LOCAL'
13003 !      include 'COMMON.CHAIN'
13004 !      include 'COMMON.DERIV'
13005 !      include 'COMMON.NAMES'
13006 !      include 'COMMON.INTERACT'
13007 !      include 'COMMON.IOUNITS'
13008 !      include 'COMMON.CALC'
13009       use comm_srutu
13010 !el      integer :: icall
13011 !el      common /srutu/ icall
13012 !     double precision rrsave(maxdim)
13013       logical :: lprn
13014 !el local variables
13015       integer :: iint,itypi,itypi1,itypj
13016       real(kind=8) :: rrij,xi,yi,zi,fac
13017       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
13018       evdw=0.0D0
13019 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13020       evdw=0.0D0
13021 !     if (icall.eq.0) then
13022 !       lprn=.true.
13023 !     else
13024         lprn=.false.
13025 !     endif
13026 !el      ind=0
13027       do i=iatsc_s,iatsc_e
13028         itypi=itype(i,1)
13029         if (itypi.eq.ntyp1) cycle
13030         itypi1=itype(i+1,1)
13031         xi=c(1,nres+i)
13032         yi=c(2,nres+i)
13033         zi=c(3,nres+i)
13034         dxi=dc_norm(1,nres+i)
13035         dyi=dc_norm(2,nres+i)
13036         dzi=dc_norm(3,nres+i)
13037 !        dsci_inv=dsc_inv(itypi)
13038         dsci_inv=vbld_inv(i+nres)
13039 !
13040 ! Calculate SC interaction energy.
13041 !
13042         do iint=1,nint_gr(i)
13043           do j=istart(i,iint),iend(i,iint)
13044 !el            ind=ind+1
13045             itypj=itype(j,1)
13046             if (itypj.eq.ntyp1) cycle
13047 !            dscj_inv=dsc_inv(itypj)
13048             dscj_inv=vbld_inv(j+nres)
13049             chi1=chi(itypi,itypj)
13050             chi2=chi(itypj,itypi)
13051             chi12=chi1*chi2
13052             chip1=chip(itypi)
13053             chip2=chip(itypj)
13054             chip12=chip1*chip2
13055             alf1=alp(itypi)
13056             alf2=alp(itypj)
13057             alf12=0.5D0*(alf1+alf2)
13058             xj=c(1,nres+j)-xi
13059             yj=c(2,nres+j)-yi
13060             zj=c(3,nres+j)-zi
13061             dxj=dc_norm(1,nres+j)
13062             dyj=dc_norm(2,nres+j)
13063             dzj=dc_norm(3,nres+j)
13064             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13065             rij=dsqrt(rrij)
13066             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13067
13068             if (sss.lt.1.0d0) then
13069
13070 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13071               call sc_angular
13072 ! Calculate whole angle-dependent part of epsilon and contributions
13073 ! to its derivatives
13074               fac=(rrij*sigsq)**expon2
13075               e1=fac*fac*aa_aq(itypi,itypj)
13076               e2=fac*bb_aq(itypi,itypj)
13077               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13078               eps2der=evdwij*eps3rt
13079               eps3der=evdwij*eps2rt
13080               evdwij=evdwij*eps2rt*eps3rt
13081               evdw=evdw+evdwij*(1.0d0-sss)
13082               if (lprn) then
13083               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13084               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13085 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13086 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13087 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13088 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13089 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13090 !d     &          evdwij
13091               endif
13092 ! Calculate gradient components.
13093               e1=e1*eps1*eps2rt**2*eps3rt**2
13094               fac=-expon*(e1+evdwij)
13095               sigder=fac/sigsq
13096               fac=rrij*fac
13097 ! Calculate radial part of the gradient
13098               gg(1)=xj*fac
13099               gg(2)=yj*fac
13100               gg(3)=zj*fac
13101 ! Calculate the angular part of the gradient and sum add the contributions
13102 ! to the appropriate components of the Cartesian gradient.
13103               call sc_grad_scale(1.0d0-sss)
13104             endif
13105           enddo      ! j
13106         enddo        ! iint
13107       enddo          ! i
13108 !     stop
13109       return
13110       end subroutine ebp_long
13111 !-----------------------------------------------------------------------------
13112       subroutine ebp_short(evdw)
13113 !
13114 ! This subroutine calculates the interaction energy of nonbonded side chains
13115 ! assuming the Berne-Pechukas potential of interaction.
13116 !
13117       use calc_data
13118 !      implicit real*8 (a-h,o-z)
13119 !      include 'DIMENSIONS'
13120 !      include 'COMMON.GEO'
13121 !      include 'COMMON.VAR'
13122 !      include 'COMMON.LOCAL'
13123 !      include 'COMMON.CHAIN'
13124 !      include 'COMMON.DERIV'
13125 !      include 'COMMON.NAMES'
13126 !      include 'COMMON.INTERACT'
13127 !      include 'COMMON.IOUNITS'
13128 !      include 'COMMON.CALC'
13129       use comm_srutu
13130 !el      integer :: icall
13131 !el      common /srutu/ icall
13132 !     double precision rrsave(maxdim)
13133       logical :: lprn
13134 !el local variables
13135       integer :: iint,itypi,itypi1,itypj
13136       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
13137       real(kind=8) :: sss,e1,e2,evdw
13138       evdw=0.0D0
13139 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13140       evdw=0.0D0
13141 !     if (icall.eq.0) then
13142 !       lprn=.true.
13143 !     else
13144         lprn=.false.
13145 !     endif
13146 !el      ind=0
13147       do i=iatsc_s,iatsc_e
13148         itypi=itype(i,1)
13149         if (itypi.eq.ntyp1) cycle
13150         itypi1=itype(i+1,1)
13151         xi=c(1,nres+i)
13152         yi=c(2,nres+i)
13153         zi=c(3,nres+i)
13154         dxi=dc_norm(1,nres+i)
13155         dyi=dc_norm(2,nres+i)
13156         dzi=dc_norm(3,nres+i)
13157 !        dsci_inv=dsc_inv(itypi)
13158         dsci_inv=vbld_inv(i+nres)
13159 !
13160 ! Calculate SC interaction energy.
13161 !
13162         do iint=1,nint_gr(i)
13163           do j=istart(i,iint),iend(i,iint)
13164 !el            ind=ind+1
13165             itypj=itype(j,1)
13166             if (itypj.eq.ntyp1) cycle
13167 !            dscj_inv=dsc_inv(itypj)
13168             dscj_inv=vbld_inv(j+nres)
13169             chi1=chi(itypi,itypj)
13170             chi2=chi(itypj,itypi)
13171             chi12=chi1*chi2
13172             chip1=chip(itypi)
13173             chip2=chip(itypj)
13174             chip12=chip1*chip2
13175             alf1=alp(itypi)
13176             alf2=alp(itypj)
13177             alf12=0.5D0*(alf1+alf2)
13178             xj=c(1,nres+j)-xi
13179             yj=c(2,nres+j)-yi
13180             zj=c(3,nres+j)-zi
13181             dxj=dc_norm(1,nres+j)
13182             dyj=dc_norm(2,nres+j)
13183             dzj=dc_norm(3,nres+j)
13184             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13185             rij=dsqrt(rrij)
13186             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13187
13188             if (sss.gt.0.0d0) then
13189
13190 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13191               call sc_angular
13192 ! Calculate whole angle-dependent part of epsilon and contributions
13193 ! to its derivatives
13194               fac=(rrij*sigsq)**expon2
13195               e1=fac*fac*aa_aq(itypi,itypj)
13196               e2=fac*bb_aq(itypi,itypj)
13197               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13198               eps2der=evdwij*eps3rt
13199               eps3der=evdwij*eps2rt
13200               evdwij=evdwij*eps2rt*eps3rt
13201               evdw=evdw+evdwij*sss
13202               if (lprn) then
13203               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13204               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13205 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13206 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13207 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13208 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13209 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13210 !d     &          evdwij
13211               endif
13212 ! Calculate gradient components.
13213               e1=e1*eps1*eps2rt**2*eps3rt**2
13214               fac=-expon*(e1+evdwij)
13215               sigder=fac/sigsq
13216               fac=rrij*fac
13217 ! Calculate radial part of the gradient
13218               gg(1)=xj*fac
13219               gg(2)=yj*fac
13220               gg(3)=zj*fac
13221 ! Calculate the angular part of the gradient and sum add the contributions
13222 ! to the appropriate components of the Cartesian gradient.
13223               call sc_grad_scale(sss)
13224             endif
13225           enddo      ! j
13226         enddo        ! iint
13227       enddo          ! i
13228 !     stop
13229       return
13230       end subroutine ebp_short
13231 !-----------------------------------------------------------------------------
13232       subroutine egb_long(evdw)
13233 !
13234 ! This subroutine calculates the interaction energy of nonbonded side chains
13235 ! assuming the Gay-Berne potential of interaction.
13236 !
13237       use calc_data
13238 !      implicit real*8 (a-h,o-z)
13239 !      include 'DIMENSIONS'
13240 !      include 'COMMON.GEO'
13241 !      include 'COMMON.VAR'
13242 !      include 'COMMON.LOCAL'
13243 !      include 'COMMON.CHAIN'
13244 !      include 'COMMON.DERIV'
13245 !      include 'COMMON.NAMES'
13246 !      include 'COMMON.INTERACT'
13247 !      include 'COMMON.IOUNITS'
13248 !      include 'COMMON.CALC'
13249 !      include 'COMMON.CONTROL'
13250       logical :: lprn
13251 !el local variables
13252       integer :: iint,itypi,itypi1,itypj,subchap
13253       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13254       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13255       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13256                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13257                     ssgradlipi,ssgradlipj
13258
13259
13260       evdw=0.0D0
13261 !cccc      energy_dec=.false.
13262 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13263       evdw=0.0D0
13264       lprn=.false.
13265 !     if (icall.eq.0) lprn=.false.
13266 !el      ind=0
13267       do i=iatsc_s,iatsc_e
13268         itypi=itype(i,1)
13269         if (itypi.eq.ntyp1) cycle
13270         itypi1=itype(i+1,1)
13271         xi=c(1,nres+i)
13272         yi=c(2,nres+i)
13273         zi=c(3,nres+i)
13274           xi=mod(xi,boxxsize)
13275           if (xi.lt.0) xi=xi+boxxsize
13276           yi=mod(yi,boxysize)
13277           if (yi.lt.0) yi=yi+boxysize
13278           zi=mod(zi,boxzsize)
13279           if (zi.lt.0) zi=zi+boxzsize
13280        if ((zi.gt.bordlipbot)    &
13281         .and.(zi.lt.bordliptop)) then
13282 !C the energy transfer exist
13283         if (zi.lt.buflipbot) then
13284 !C what fraction I am in
13285          fracinbuf=1.0d0-    &
13286              ((zi-bordlipbot)/lipbufthick)
13287 !C lipbufthick is thickenes of lipid buffore
13288          sslipi=sscalelip(fracinbuf)
13289          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13290         elseif (zi.gt.bufliptop) then
13291          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13292          sslipi=sscalelip(fracinbuf)
13293          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13294         else
13295          sslipi=1.0d0
13296          ssgradlipi=0.0
13297         endif
13298        else
13299          sslipi=0.0d0
13300          ssgradlipi=0.0
13301        endif
13302
13303         dxi=dc_norm(1,nres+i)
13304         dyi=dc_norm(2,nres+i)
13305         dzi=dc_norm(3,nres+i)
13306 !        dsci_inv=dsc_inv(itypi)
13307         dsci_inv=vbld_inv(i+nres)
13308 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13309 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13310 !
13311 ! Calculate SC interaction energy.
13312 !
13313         do iint=1,nint_gr(i)
13314           do j=istart(i,iint),iend(i,iint)
13315             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13316 !              call dyn_ssbond_ene(i,j,evdwij)
13317 !              evdw=evdw+evdwij
13318 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13319 !                              'evdw',i,j,evdwij,' ss'
13320 !              if (energy_dec) write (iout,*) &
13321 !                              'evdw',i,j,evdwij,' ss'
13322 !             do k=j+1,iend(i,iint)
13323 !C search over all next residues
13324 !              if (dyn_ss_mask(k)) then
13325 !C check if they are cysteins
13326 !C              write(iout,*) 'k=',k
13327
13328 !c              write(iout,*) "PRZED TRI", evdwij
13329 !               evdwij_przed_tri=evdwij
13330 !              call triple_ssbond_ene(i,j,k,evdwij)
13331 !c               if(evdwij_przed_tri.ne.evdwij) then
13332 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13333 !c               endif
13334
13335 !c              write(iout,*) "PO TRI", evdwij
13336 !C call the energy function that removes the artifical triple disulfide
13337 !C bond the soubroutine is located in ssMD.F
13338 !              evdw=evdw+evdwij
13339               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13340                             'evdw',i,j,evdwij,'tss'
13341 !              endif!dyn_ss_mask(k)
13342 !             enddo! k
13343
13344             ELSE
13345 !el            ind=ind+1
13346             itypj=itype(j,1)
13347             if (itypj.eq.ntyp1) cycle
13348 !            dscj_inv=dsc_inv(itypj)
13349             dscj_inv=vbld_inv(j+nres)
13350 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13351 !     &       1.0d0/vbld(j+nres)
13352 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13353             sig0ij=sigma(itypi,itypj)
13354             chi1=chi(itypi,itypj)
13355             chi2=chi(itypj,itypi)
13356             chi12=chi1*chi2
13357             chip1=chip(itypi)
13358             chip2=chip(itypj)
13359             chip12=chip1*chip2
13360             alf1=alp(itypi)
13361             alf2=alp(itypj)
13362             alf12=0.5D0*(alf1+alf2)
13363             xj=c(1,nres+j)
13364             yj=c(2,nres+j)
13365             zj=c(3,nres+j)
13366 ! Searching for nearest neighbour
13367           xj=mod(xj,boxxsize)
13368           if (xj.lt.0) xj=xj+boxxsize
13369           yj=mod(yj,boxysize)
13370           if (yj.lt.0) yj=yj+boxysize
13371           zj=mod(zj,boxzsize)
13372           if (zj.lt.0) zj=zj+boxzsize
13373        if ((zj.gt.bordlipbot)   &
13374       .and.(zj.lt.bordliptop)) then
13375 !C the energy transfer exist
13376         if (zj.lt.buflipbot) then
13377 !C what fraction I am in
13378          fracinbuf=1.0d0-  &
13379              ((zj-bordlipbot)/lipbufthick)
13380 !C lipbufthick is thickenes of lipid buffore
13381          sslipj=sscalelip(fracinbuf)
13382          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13383         elseif (zj.gt.bufliptop) then
13384          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13385          sslipj=sscalelip(fracinbuf)
13386          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13387         else
13388          sslipj=1.0d0
13389          ssgradlipj=0.0
13390         endif
13391        else
13392          sslipj=0.0d0
13393          ssgradlipj=0.0
13394        endif
13395       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13396        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13397       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13398        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13399
13400           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13401           xj_safe=xj
13402           yj_safe=yj
13403           zj_safe=zj
13404           subchap=0
13405           do xshift=-1,1
13406           do yshift=-1,1
13407           do zshift=-1,1
13408           xj=xj_safe+xshift*boxxsize
13409           yj=yj_safe+yshift*boxysize
13410           zj=zj_safe+zshift*boxzsize
13411           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13412           if(dist_temp.lt.dist_init) then
13413             dist_init=dist_temp
13414             xj_temp=xj
13415             yj_temp=yj
13416             zj_temp=zj
13417             subchap=1
13418           endif
13419           enddo
13420           enddo
13421           enddo
13422           if (subchap.eq.1) then
13423           xj=xj_temp-xi
13424           yj=yj_temp-yi
13425           zj=zj_temp-zi
13426           else
13427           xj=xj_safe-xi
13428           yj=yj_safe-yi
13429           zj=zj_safe-zi
13430           endif
13431
13432             dxj=dc_norm(1,nres+j)
13433             dyj=dc_norm(2,nres+j)
13434             dzj=dc_norm(3,nres+j)
13435             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13436             rij=dsqrt(rrij)
13437             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13438             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13439             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13440             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13441             if (sss_ele_cut.le.0.0) cycle
13442             if (sss.lt.1.0d0) then
13443
13444 ! Calculate angle-dependent terms of energy and contributions to their
13445 ! derivatives.
13446               call sc_angular
13447               sigsq=1.0D0/sigsq
13448               sig=sig0ij*dsqrt(sigsq)
13449               rij_shift=1.0D0/rij-sig+sig0ij
13450 ! for diagnostics; uncomment
13451 !              rij_shift=1.2*sig0ij
13452 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13453               if (rij_shift.le.0.0D0) then
13454                 evdw=1.0D20
13455 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13456 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13457 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13458                 return
13459               endif
13460               sigder=-sig*sigsq
13461 !---------------------------------------------------------------
13462               rij_shift=1.0D0/rij_shift
13463               fac=rij_shift**expon
13464               e1=fac*fac*aa
13465               e2=fac*bb
13466               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13467               eps2der=evdwij*eps3rt
13468               eps3der=evdwij*eps2rt
13469 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13470 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13471               evdwij=evdwij*eps2rt*eps3rt
13472               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13473               if (lprn) then
13474               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13475               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13476               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13477                 restyp(itypi,1),i,restyp(itypj,1),j,&
13478                 epsi,sigm,chi1,chi2,chip1,chip2,&
13479                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13480                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13481                 evdwij
13482               endif
13483
13484               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13485                               'evdw',i,j,evdwij
13486 !              if (energy_dec) write (iout,*) &
13487 !                              'evdw',i,j,evdwij,"egb_long"
13488
13489 ! Calculate gradient components.
13490               e1=e1*eps1*eps2rt**2*eps3rt**2
13491               fac=-expon*(e1+evdwij)*rij_shift
13492               sigder=fac*sigder
13493               fac=rij*fac
13494               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13495             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
13496             /sigmaii(itypi,itypj))
13497 !              fac=0.0d0
13498 ! Calculate the radial part of the gradient
13499               gg(1)=xj*fac
13500               gg(2)=yj*fac
13501               gg(3)=zj*fac
13502 ! Calculate angular part of the gradient.
13503               call sc_grad_scale(1.0d0-sss)
13504             ENDIF    !mask_dyn_ss
13505             endif
13506           enddo      ! j
13507         enddo        ! iint
13508       enddo          ! i
13509 !      write (iout,*) "Number of loop steps in EGB:",ind
13510 !ccc      energy_dec=.false.
13511       return
13512       end subroutine egb_long
13513 !-----------------------------------------------------------------------------
13514       subroutine egb_short(evdw)
13515 !
13516 ! This subroutine calculates the interaction energy of nonbonded side chains
13517 ! assuming the Gay-Berne potential of interaction.
13518 !
13519       use calc_data
13520 !      implicit real*8 (a-h,o-z)
13521 !      include 'DIMENSIONS'
13522 !      include 'COMMON.GEO'
13523 !      include 'COMMON.VAR'
13524 !      include 'COMMON.LOCAL'
13525 !      include 'COMMON.CHAIN'
13526 !      include 'COMMON.DERIV'
13527 !      include 'COMMON.NAMES'
13528 !      include 'COMMON.INTERACT'
13529 !      include 'COMMON.IOUNITS'
13530 !      include 'COMMON.CALC'
13531 !      include 'COMMON.CONTROL'
13532       logical :: lprn
13533 !el local variables
13534       integer :: iint,itypi,itypi1,itypj,subchap
13535       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
13536       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
13537       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13538                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13539                     ssgradlipi,ssgradlipj
13540       evdw=0.0D0
13541 !cccc      energy_dec=.false.
13542 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13543       evdw=0.0D0
13544       lprn=.false.
13545 !     if (icall.eq.0) lprn=.false.
13546 !el      ind=0
13547       do i=iatsc_s,iatsc_e
13548         itypi=itype(i,1)
13549         if (itypi.eq.ntyp1) cycle
13550         itypi1=itype(i+1,1)
13551         xi=c(1,nres+i)
13552         yi=c(2,nres+i)
13553         zi=c(3,nres+i)
13554           xi=mod(xi,boxxsize)
13555           if (xi.lt.0) xi=xi+boxxsize
13556           yi=mod(yi,boxysize)
13557           if (yi.lt.0) yi=yi+boxysize
13558           zi=mod(zi,boxzsize)
13559           if (zi.lt.0) zi=zi+boxzsize
13560        if ((zi.gt.bordlipbot)    &
13561         .and.(zi.lt.bordliptop)) then
13562 !C the energy transfer exist
13563         if (zi.lt.buflipbot) then
13564 !C what fraction I am in
13565          fracinbuf=1.0d0-    &
13566              ((zi-bordlipbot)/lipbufthick)
13567 !C lipbufthick is thickenes of lipid buffore
13568          sslipi=sscalelip(fracinbuf)
13569          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13570         elseif (zi.gt.bufliptop) then
13571          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13572          sslipi=sscalelip(fracinbuf)
13573          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13574         else
13575          sslipi=1.0d0
13576          ssgradlipi=0.0
13577         endif
13578        else
13579          sslipi=0.0d0
13580          ssgradlipi=0.0
13581        endif
13582
13583         dxi=dc_norm(1,nres+i)
13584         dyi=dc_norm(2,nres+i)
13585         dzi=dc_norm(3,nres+i)
13586 !        dsci_inv=dsc_inv(itypi)
13587         dsci_inv=vbld_inv(i+nres)
13588
13589         dxi=dc_norm(1,nres+i)
13590         dyi=dc_norm(2,nres+i)
13591         dzi=dc_norm(3,nres+i)
13592 !        dsci_inv=dsc_inv(itypi)
13593         dsci_inv=vbld_inv(i+nres)
13594 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13595 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13596 !
13597 ! Calculate SC interaction energy.
13598 !
13599         do iint=1,nint_gr(i)
13600           do j=istart(i,iint),iend(i,iint)
13601             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13602               call dyn_ssbond_ene(i,j,evdwij)
13603               evdw=evdw+evdwij
13604               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13605                               'evdw',i,j,evdwij,' ss'
13606              do k=j+1,iend(i,iint)
13607 !C search over all next residues
13608               if (dyn_ss_mask(k)) then
13609 !C check if they are cysteins
13610 !C              write(iout,*) 'k=',k
13611
13612 !c              write(iout,*) "PRZED TRI", evdwij
13613 !               evdwij_przed_tri=evdwij
13614               call triple_ssbond_ene(i,j,k,evdwij)
13615 !c               if(evdwij_przed_tri.ne.evdwij) then
13616 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13617 !c               endif
13618
13619 !c              write(iout,*) "PO TRI", evdwij
13620 !C call the energy function that removes the artifical triple disulfide
13621 !C bond the soubroutine is located in ssMD.F
13622               evdw=evdw+evdwij
13623               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13624                             'evdw',i,j,evdwij,'tss'
13625               endif!dyn_ss_mask(k)
13626              enddo! k
13627
13628 !              if (energy_dec) write (iout,*) &
13629 !                              'evdw',i,j,evdwij,' ss'
13630             ELSE
13631 !el            ind=ind+1
13632             itypj=itype(j,1)
13633             if (itypj.eq.ntyp1) cycle
13634 !            dscj_inv=dsc_inv(itypj)
13635             dscj_inv=vbld_inv(j+nres)
13636 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13637 !     &       1.0d0/vbld(j+nres)
13638 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13639             sig0ij=sigma(itypi,itypj)
13640             chi1=chi(itypi,itypj)
13641             chi2=chi(itypj,itypi)
13642             chi12=chi1*chi2
13643             chip1=chip(itypi)
13644             chip2=chip(itypj)
13645             chip12=chip1*chip2
13646             alf1=alp(itypi)
13647             alf2=alp(itypj)
13648             alf12=0.5D0*(alf1+alf2)
13649 !            xj=c(1,nres+j)-xi
13650 !            yj=c(2,nres+j)-yi
13651 !            zj=c(3,nres+j)-zi
13652             xj=c(1,nres+j)
13653             yj=c(2,nres+j)
13654             zj=c(3,nres+j)
13655 ! Searching for nearest neighbour
13656           xj=mod(xj,boxxsize)
13657           if (xj.lt.0) xj=xj+boxxsize
13658           yj=mod(yj,boxysize)
13659           if (yj.lt.0) yj=yj+boxysize
13660           zj=mod(zj,boxzsize)
13661           if (zj.lt.0) zj=zj+boxzsize
13662        if ((zj.gt.bordlipbot)   &
13663       .and.(zj.lt.bordliptop)) then
13664 !C the energy transfer exist
13665         if (zj.lt.buflipbot) then
13666 !C what fraction I am in
13667          fracinbuf=1.0d0-  &
13668              ((zj-bordlipbot)/lipbufthick)
13669 !C lipbufthick is thickenes of lipid buffore
13670          sslipj=sscalelip(fracinbuf)
13671          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13672         elseif (zj.gt.bufliptop) then
13673          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13674          sslipj=sscalelip(fracinbuf)
13675          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13676         else
13677          sslipj=1.0d0
13678          ssgradlipj=0.0
13679         endif
13680        else
13681          sslipj=0.0d0
13682          ssgradlipj=0.0
13683        endif
13684       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13685        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13686       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13687        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13688
13689           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13690           xj_safe=xj
13691           yj_safe=yj
13692           zj_safe=zj
13693           subchap=0
13694
13695           do xshift=-1,1
13696           do yshift=-1,1
13697           do zshift=-1,1
13698           xj=xj_safe+xshift*boxxsize
13699           yj=yj_safe+yshift*boxysize
13700           zj=zj_safe+zshift*boxzsize
13701           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13702           if(dist_temp.lt.dist_init) then
13703             dist_init=dist_temp
13704             xj_temp=xj
13705             yj_temp=yj
13706             zj_temp=zj
13707             subchap=1
13708           endif
13709           enddo
13710           enddo
13711           enddo
13712           if (subchap.eq.1) then
13713           xj=xj_temp-xi
13714           yj=yj_temp-yi
13715           zj=zj_temp-zi
13716           else
13717           xj=xj_safe-xi
13718           yj=yj_safe-yi
13719           zj=zj_safe-zi
13720           endif
13721
13722             dxj=dc_norm(1,nres+j)
13723             dyj=dc_norm(2,nres+j)
13724             dzj=dc_norm(3,nres+j)
13725             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13726             rij=dsqrt(rrij)
13727             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13728             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13729             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13730             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13731             if (sss_ele_cut.le.0.0) cycle
13732
13733             if (sss.gt.0.0d0) then
13734
13735 ! Calculate angle-dependent terms of energy and contributions to their
13736 ! derivatives.
13737               call sc_angular
13738               sigsq=1.0D0/sigsq
13739               sig=sig0ij*dsqrt(sigsq)
13740               rij_shift=1.0D0/rij-sig+sig0ij
13741 ! for diagnostics; uncomment
13742 !              rij_shift=1.2*sig0ij
13743 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13744               if (rij_shift.le.0.0D0) then
13745                 evdw=1.0D20
13746 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13747 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13748 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13749                 return
13750               endif
13751               sigder=-sig*sigsq
13752 !---------------------------------------------------------------
13753               rij_shift=1.0D0/rij_shift
13754               fac=rij_shift**expon
13755               e1=fac*fac*aa
13756               e2=fac*bb
13757               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13758               eps2der=evdwij*eps3rt
13759               eps3der=evdwij*eps2rt
13760 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13761 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13762               evdwij=evdwij*eps2rt*eps3rt
13763               evdw=evdw+evdwij*sss*sss_ele_cut
13764               if (lprn) then
13765               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13766               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13767               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13768                 restyp(itypi,1),i,restyp(itypj,1),j,&
13769                 epsi,sigm,chi1,chi2,chip1,chip2,&
13770                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13771                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13772                 evdwij
13773               endif
13774
13775               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13776                               'evdw',i,j,evdwij
13777 !              if (energy_dec) write (iout,*) &
13778 !                              'evdw',i,j,evdwij,"egb_short"
13779
13780 ! Calculate gradient components.
13781               e1=e1*eps1*eps2rt**2*eps3rt**2
13782               fac=-expon*(e1+evdwij)*rij_shift
13783               sigder=fac*sigder
13784               fac=rij*fac
13785               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13786             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13787             /sigmaii(itypi,itypj))
13788
13789 !              fac=0.0d0
13790 ! Calculate the radial part of the gradient
13791               gg(1)=xj*fac
13792               gg(2)=yj*fac
13793               gg(3)=zj*fac
13794 ! Calculate angular part of the gradient.
13795               call sc_grad_scale(sss)
13796             endif
13797           ENDIF !mask_dyn_ss
13798           enddo      ! j
13799         enddo        ! iint
13800       enddo          ! i
13801 !      write (iout,*) "Number of loop steps in EGB:",ind
13802 !ccc      energy_dec=.false.
13803       return
13804       end subroutine egb_short
13805 !-----------------------------------------------------------------------------
13806       subroutine egbv_long(evdw)
13807 !
13808 ! This subroutine calculates the interaction energy of nonbonded side chains
13809 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13810 !
13811       use calc_data
13812 !      implicit real*8 (a-h,o-z)
13813 !      include 'DIMENSIONS'
13814 !      include 'COMMON.GEO'
13815 !      include 'COMMON.VAR'
13816 !      include 'COMMON.LOCAL'
13817 !      include 'COMMON.CHAIN'
13818 !      include 'COMMON.DERIV'
13819 !      include 'COMMON.NAMES'
13820 !      include 'COMMON.INTERACT'
13821 !      include 'COMMON.IOUNITS'
13822 !      include 'COMMON.CALC'
13823       use comm_srutu
13824 !el      integer :: icall
13825 !el      common /srutu/ icall
13826       logical :: lprn
13827 !el local variables
13828       integer :: iint,itypi,itypi1,itypj
13829       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13830       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13831       evdw=0.0D0
13832 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13833       evdw=0.0D0
13834       lprn=.false.
13835 !     if (icall.eq.0) lprn=.true.
13836 !el      ind=0
13837       do i=iatsc_s,iatsc_e
13838         itypi=itype(i,1)
13839         if (itypi.eq.ntyp1) cycle
13840         itypi1=itype(i+1,1)
13841         xi=c(1,nres+i)
13842         yi=c(2,nres+i)
13843         zi=c(3,nres+i)
13844         dxi=dc_norm(1,nres+i)
13845         dyi=dc_norm(2,nres+i)
13846         dzi=dc_norm(3,nres+i)
13847 !        dsci_inv=dsc_inv(itypi)
13848         dsci_inv=vbld_inv(i+nres)
13849 !
13850 ! Calculate SC interaction energy.
13851 !
13852         do iint=1,nint_gr(i)
13853           do j=istart(i,iint),iend(i,iint)
13854 !el            ind=ind+1
13855             itypj=itype(j,1)
13856             if (itypj.eq.ntyp1) cycle
13857 !            dscj_inv=dsc_inv(itypj)
13858             dscj_inv=vbld_inv(j+nres)
13859             sig0ij=sigma(itypi,itypj)
13860             r0ij=r0(itypi,itypj)
13861             chi1=chi(itypi,itypj)
13862             chi2=chi(itypj,itypi)
13863             chi12=chi1*chi2
13864             chip1=chip(itypi)
13865             chip2=chip(itypj)
13866             chip12=chip1*chip2
13867             alf1=alp(itypi)
13868             alf2=alp(itypj)
13869             alf12=0.5D0*(alf1+alf2)
13870             xj=c(1,nres+j)-xi
13871             yj=c(2,nres+j)-yi
13872             zj=c(3,nres+j)-zi
13873             dxj=dc_norm(1,nres+j)
13874             dyj=dc_norm(2,nres+j)
13875             dzj=dc_norm(3,nres+j)
13876             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13877             rij=dsqrt(rrij)
13878
13879             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13880
13881             if (sss.lt.1.0d0) then
13882
13883 ! Calculate angle-dependent terms of energy and contributions to their
13884 ! derivatives.
13885               call sc_angular
13886               sigsq=1.0D0/sigsq
13887               sig=sig0ij*dsqrt(sigsq)
13888               rij_shift=1.0D0/rij-sig+r0ij
13889 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13890               if (rij_shift.le.0.0D0) then
13891                 evdw=1.0D20
13892                 return
13893               endif
13894               sigder=-sig*sigsq
13895 !---------------------------------------------------------------
13896               rij_shift=1.0D0/rij_shift
13897               fac=rij_shift**expon
13898               e1=fac*fac*aa_aq(itypi,itypj)
13899               e2=fac*bb_aq(itypi,itypj)
13900               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13901               eps2der=evdwij*eps3rt
13902               eps3der=evdwij*eps2rt
13903               fac_augm=rrij**expon
13904               e_augm=augm(itypi,itypj)*fac_augm
13905               evdwij=evdwij*eps2rt*eps3rt
13906               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13907               if (lprn) then
13908               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13909               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13910               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13911                 restyp(itypi,1),i,restyp(itypj,1),j,&
13912                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13913                 chi1,chi2,chip1,chip2,&
13914                 eps1,eps2rt**2,eps3rt**2,&
13915                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13916                 evdwij+e_augm
13917               endif
13918 ! Calculate gradient components.
13919               e1=e1*eps1*eps2rt**2*eps3rt**2
13920               fac=-expon*(e1+evdwij)*rij_shift
13921               sigder=fac*sigder
13922               fac=rij*fac-2*expon*rrij*e_augm
13923 ! Calculate the radial part of the gradient
13924               gg(1)=xj*fac
13925               gg(2)=yj*fac
13926               gg(3)=zj*fac
13927 ! Calculate angular part of the gradient.
13928               call sc_grad_scale(1.0d0-sss)
13929             endif
13930           enddo      ! j
13931         enddo        ! iint
13932       enddo          ! i
13933       end subroutine egbv_long
13934 !-----------------------------------------------------------------------------
13935       subroutine egbv_short(evdw)
13936 !
13937 ! This subroutine calculates the interaction energy of nonbonded side chains
13938 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13939 !
13940       use calc_data
13941 !      implicit real*8 (a-h,o-z)
13942 !      include 'DIMENSIONS'
13943 !      include 'COMMON.GEO'
13944 !      include 'COMMON.VAR'
13945 !      include 'COMMON.LOCAL'
13946 !      include 'COMMON.CHAIN'
13947 !      include 'COMMON.DERIV'
13948 !      include 'COMMON.NAMES'
13949 !      include 'COMMON.INTERACT'
13950 !      include 'COMMON.IOUNITS'
13951 !      include 'COMMON.CALC'
13952       use comm_srutu
13953 !el      integer :: icall
13954 !el      common /srutu/ icall
13955       logical :: lprn
13956 !el local variables
13957       integer :: iint,itypi,itypi1,itypj
13958       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
13959       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
13960       evdw=0.0D0
13961 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13962       evdw=0.0D0
13963       lprn=.false.
13964 !     if (icall.eq.0) lprn=.true.
13965 !el      ind=0
13966       do i=iatsc_s,iatsc_e
13967         itypi=itype(i,1)
13968         if (itypi.eq.ntyp1) cycle
13969         itypi1=itype(i+1,1)
13970         xi=c(1,nres+i)
13971         yi=c(2,nres+i)
13972         zi=c(3,nres+i)
13973         dxi=dc_norm(1,nres+i)
13974         dyi=dc_norm(2,nres+i)
13975         dzi=dc_norm(3,nres+i)
13976 !        dsci_inv=dsc_inv(itypi)
13977         dsci_inv=vbld_inv(i+nres)
13978 !
13979 ! Calculate SC interaction energy.
13980 !
13981         do iint=1,nint_gr(i)
13982           do j=istart(i,iint),iend(i,iint)
13983 !el            ind=ind+1
13984             itypj=itype(j,1)
13985             if (itypj.eq.ntyp1) cycle
13986 !            dscj_inv=dsc_inv(itypj)
13987             dscj_inv=vbld_inv(j+nres)
13988             sig0ij=sigma(itypi,itypj)
13989             r0ij=r0(itypi,itypj)
13990             chi1=chi(itypi,itypj)
13991             chi2=chi(itypj,itypi)
13992             chi12=chi1*chi2
13993             chip1=chip(itypi)
13994             chip2=chip(itypj)
13995             chip12=chip1*chip2
13996             alf1=alp(itypi)
13997             alf2=alp(itypj)
13998             alf12=0.5D0*(alf1+alf2)
13999             xj=c(1,nres+j)-xi
14000             yj=c(2,nres+j)-yi
14001             zj=c(3,nres+j)-zi
14002             dxj=dc_norm(1,nres+j)
14003             dyj=dc_norm(2,nres+j)
14004             dzj=dc_norm(3,nres+j)
14005             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14006             rij=dsqrt(rrij)
14007
14008             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14009
14010             if (sss.gt.0.0d0) then
14011
14012 ! Calculate angle-dependent terms of energy and contributions to their
14013 ! derivatives.
14014               call sc_angular
14015               sigsq=1.0D0/sigsq
14016               sig=sig0ij*dsqrt(sigsq)
14017               rij_shift=1.0D0/rij-sig+r0ij
14018 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14019               if (rij_shift.le.0.0D0) then
14020                 evdw=1.0D20
14021                 return
14022               endif
14023               sigder=-sig*sigsq
14024 !---------------------------------------------------------------
14025               rij_shift=1.0D0/rij_shift
14026               fac=rij_shift**expon
14027               e1=fac*fac*aa_aq(itypi,itypj)
14028               e2=fac*bb_aq(itypi,itypj)
14029               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14030               eps2der=evdwij*eps3rt
14031               eps3der=evdwij*eps2rt
14032               fac_augm=rrij**expon
14033               e_augm=augm(itypi,itypj)*fac_augm
14034               evdwij=evdwij*eps2rt*eps3rt
14035               evdw=evdw+(evdwij+e_augm)*sss
14036               if (lprn) then
14037               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14038               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14039               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14040                 restyp(itypi,1),i,restyp(itypj,1),j,&
14041                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14042                 chi1,chi2,chip1,chip2,&
14043                 eps1,eps2rt**2,eps3rt**2,&
14044                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14045                 evdwij+e_augm
14046               endif
14047 ! Calculate gradient components.
14048               e1=e1*eps1*eps2rt**2*eps3rt**2
14049               fac=-expon*(e1+evdwij)*rij_shift
14050               sigder=fac*sigder
14051               fac=rij*fac-2*expon*rrij*e_augm
14052 ! Calculate the radial part of the gradient
14053               gg(1)=xj*fac
14054               gg(2)=yj*fac
14055               gg(3)=zj*fac
14056 ! Calculate angular part of the gradient.
14057               call sc_grad_scale(sss)
14058             endif
14059           enddo      ! j
14060         enddo        ! iint
14061       enddo          ! i
14062       end subroutine egbv_short
14063 !-----------------------------------------------------------------------------
14064       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
14065 !
14066 ! This subroutine calculates the average interaction energy and its gradient
14067 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
14068 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
14069 ! The potential depends both on the distance of peptide-group centers and on
14070 ! the orientation of the CA-CA virtual bonds.
14071 !
14072 !      implicit real*8 (a-h,o-z)
14073
14074       use comm_locel
14075 #ifdef MPI
14076       include 'mpif.h'
14077 #endif
14078 !      include 'DIMENSIONS'
14079 !      include 'COMMON.CONTROL'
14080 !      include 'COMMON.SETUP'
14081 !      include 'COMMON.IOUNITS'
14082 !      include 'COMMON.GEO'
14083 !      include 'COMMON.VAR'
14084 !      include 'COMMON.LOCAL'
14085 !      include 'COMMON.CHAIN'
14086 !      include 'COMMON.DERIV'
14087 !      include 'COMMON.INTERACT'
14088 !      include 'COMMON.CONTACTS'
14089 !      include 'COMMON.TORSION'
14090 !      include 'COMMON.VECTORS'
14091 !      include 'COMMON.FFIELD'
14092 !      include 'COMMON.TIME1'
14093       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
14094       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
14095       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14096 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14097       real(kind=8),dimension(4) :: muij
14098 !el      integer :: num_conti,j1,j2
14099 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14100 !el                   dz_normi,xmedi,ymedi,zmedi
14101 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14102 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14103 !el          num_conti,j1,j2
14104 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14105 #ifdef MOMENT
14106       real(kind=8) :: scal_el=1.0d0
14107 #else
14108       real(kind=8) :: scal_el=0.5d0
14109 #endif
14110 ! 12/13/98
14111 ! 13-go grudnia roku pamietnego...
14112       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14113                                              0.0d0,1.0d0,0.0d0,&
14114                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14115 !el local variables
14116       integer :: i,j,k
14117       real(kind=8) :: fac
14118       real(kind=8) :: dxj,dyj,dzj
14119       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
14120
14121 !      allocate(num_cont_hb(nres)) !(maxres)
14122 !d      write(iout,*) 'In EELEC'
14123 !d      do i=1,nloctyp
14124 !d        write(iout,*) 'Type',i
14125 !d        write(iout,*) 'B1',B1(:,i)
14126 !d        write(iout,*) 'B2',B2(:,i)
14127 !d        write(iout,*) 'CC',CC(:,:,i)
14128 !d        write(iout,*) 'DD',DD(:,:,i)
14129 !d        write(iout,*) 'EE',EE(:,:,i)
14130 !d      enddo
14131 !d      call check_vecgrad
14132 !d      stop
14133       if (icheckgrad.eq.1) then
14134         do i=1,nres-1
14135           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
14136           do k=1,3
14137             dc_norm(k,i)=dc(k,i)*fac
14138           enddo
14139 !          write (iout,*) 'i',i,' fac',fac
14140         enddo
14141       endif
14142       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14143           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
14144           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
14145 !        call vec_and_deriv
14146 #ifdef TIMING
14147         time01=MPI_Wtime()
14148 #endif
14149 !        print *, "before set matrices"
14150         call set_matrices
14151 !        print *,"after set martices"
14152 #ifdef TIMING
14153         time_mat=time_mat+MPI_Wtime()-time01
14154 #endif
14155       endif
14156 !d      do i=1,nres-1
14157 !d        write (iout,*) 'i=',i
14158 !d        do k=1,3
14159 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14160 !d        enddo
14161 !d        do k=1,3
14162 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14163 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14164 !d        enddo
14165 !d      enddo
14166       t_eelecij=0.0d0
14167       ees=0.0D0
14168       evdw1=0.0D0
14169       eel_loc=0.0d0
14170       eello_turn3=0.0d0
14171       eello_turn4=0.0d0
14172 !el      ind=0
14173       do i=1,nres
14174         num_cont_hb(i)=0
14175       enddo
14176 !d      print '(a)','Enter EELEC'
14177 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14178 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14179 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14180       do i=1,nres
14181         gel_loc_loc(i)=0.0d0
14182         gcorr_loc(i)=0.0d0
14183       enddo
14184 !
14185 !
14186 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14187 !
14188 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14189 !
14190       do i=iturn3_start,iturn3_end
14191         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14192         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14193         dxi=dc(1,i)
14194         dyi=dc(2,i)
14195         dzi=dc(3,i)
14196         dx_normi=dc_norm(1,i)
14197         dy_normi=dc_norm(2,i)
14198         dz_normi=dc_norm(3,i)
14199         xmedi=c(1,i)+0.5d0*dxi
14200         ymedi=c(2,i)+0.5d0*dyi
14201         zmedi=c(3,i)+0.5d0*dzi
14202           xmedi=dmod(xmedi,boxxsize)
14203           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14204           ymedi=dmod(ymedi,boxysize)
14205           if (ymedi.lt.0) ymedi=ymedi+boxysize
14206           zmedi=dmod(zmedi,boxzsize)
14207           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14208         num_conti=0
14209         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14210         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14211         num_cont_hb(i)=num_conti
14212       enddo
14213       do i=iturn4_start,iturn4_end
14214         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14215           .or. itype(i+3,1).eq.ntyp1 &
14216           .or. itype(i+4,1).eq.ntyp1) cycle
14217         dxi=dc(1,i)
14218         dyi=dc(2,i)
14219         dzi=dc(3,i)
14220         dx_normi=dc_norm(1,i)
14221         dy_normi=dc_norm(2,i)
14222         dz_normi=dc_norm(3,i)
14223         xmedi=c(1,i)+0.5d0*dxi
14224         ymedi=c(2,i)+0.5d0*dyi
14225         zmedi=c(3,i)+0.5d0*dzi
14226           xmedi=dmod(xmedi,boxxsize)
14227           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14228           ymedi=dmod(ymedi,boxysize)
14229           if (ymedi.lt.0) ymedi=ymedi+boxysize
14230           zmedi=dmod(zmedi,boxzsize)
14231           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14232         num_conti=num_cont_hb(i)
14233         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14234         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14235           call eturn4(i,eello_turn4)
14236         num_cont_hb(i)=num_conti
14237       enddo   ! i
14238 !
14239 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14240 !
14241       do i=iatel_s,iatel_e
14242         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14243         dxi=dc(1,i)
14244         dyi=dc(2,i)
14245         dzi=dc(3,i)
14246         dx_normi=dc_norm(1,i)
14247         dy_normi=dc_norm(2,i)
14248         dz_normi=dc_norm(3,i)
14249         xmedi=c(1,i)+0.5d0*dxi
14250         ymedi=c(2,i)+0.5d0*dyi
14251         zmedi=c(3,i)+0.5d0*dzi
14252           xmedi=dmod(xmedi,boxxsize)
14253           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14254           ymedi=dmod(ymedi,boxysize)
14255           if (ymedi.lt.0) ymedi=ymedi+boxysize
14256           zmedi=dmod(zmedi,boxzsize)
14257           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14258 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14259         num_conti=num_cont_hb(i)
14260         do j=ielstart(i),ielend(i)
14261           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14262           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14263         enddo ! j
14264         num_cont_hb(i)=num_conti
14265       enddo   ! i
14266 !      write (iout,*) "Number of loop steps in EELEC:",ind
14267 !d      do i=1,nres
14268 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14269 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14270 !d      enddo
14271 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14272 !cc      eel_loc=eel_loc+eello_turn3
14273 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14274       return
14275       end subroutine eelec_scale
14276 !-----------------------------------------------------------------------------
14277       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14278 !      implicit real*8 (a-h,o-z)
14279
14280       use comm_locel
14281 !      include 'DIMENSIONS'
14282 #ifdef MPI
14283       include "mpif.h"
14284 #endif
14285 !      include 'COMMON.CONTROL'
14286 !      include 'COMMON.IOUNITS'
14287 !      include 'COMMON.GEO'
14288 !      include 'COMMON.VAR'
14289 !      include 'COMMON.LOCAL'
14290 !      include 'COMMON.CHAIN'
14291 !      include 'COMMON.DERIV'
14292 !      include 'COMMON.INTERACT'
14293 !      include 'COMMON.CONTACTS'
14294 !      include 'COMMON.TORSION'
14295 !      include 'COMMON.VECTORS'
14296 !      include 'COMMON.FFIELD'
14297 !      include 'COMMON.TIME1'
14298       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14299       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14300       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14301 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14302       real(kind=8),dimension(4) :: muij
14303       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14304                     dist_temp, dist_init,sss_grad
14305       integer xshift,yshift,zshift
14306
14307 !el      integer :: num_conti,j1,j2
14308 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14309 !el                   dz_normi,xmedi,ymedi,zmedi
14310 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14311 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14312 !el          num_conti,j1,j2
14313 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14314 #ifdef MOMENT
14315       real(kind=8) :: scal_el=1.0d0
14316 #else
14317       real(kind=8) :: scal_el=0.5d0
14318 #endif
14319 ! 12/13/98
14320 ! 13-go grudnia roku pamietnego...
14321       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14322                                              0.0d0,1.0d0,0.0d0,&
14323                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14324 !el local variables
14325       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14326       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14327       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14328       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14329       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14330       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14331       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14332                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14333                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14334                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14335                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14336                   ecosam,ecosbm,ecosgm,ghalf,time00
14337 !      integer :: maxconts
14338 !      maxconts = nres/4
14339 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14340 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14341 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14342 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14343 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14344 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14345 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14346 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14347 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14348 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14349 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14350 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14351 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14352
14353 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14354 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14355
14356 #ifdef MPI
14357           time00=MPI_Wtime()
14358 #endif
14359 !d      write (iout,*) "eelecij",i,j
14360 !el          ind=ind+1
14361           iteli=itel(i)
14362           itelj=itel(j)
14363           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14364           aaa=app(iteli,itelj)
14365           bbb=bpp(iteli,itelj)
14366           ael6i=ael6(iteli,itelj)
14367           ael3i=ael3(iteli,itelj)
14368           dxj=dc(1,j)
14369           dyj=dc(2,j)
14370           dzj=dc(3,j)
14371           dx_normj=dc_norm(1,j)
14372           dy_normj=dc_norm(2,j)
14373           dz_normj=dc_norm(3,j)
14374 !          xj=c(1,j)+0.5D0*dxj-xmedi
14375 !          yj=c(2,j)+0.5D0*dyj-ymedi
14376 !          zj=c(3,j)+0.5D0*dzj-zmedi
14377           xj=c(1,j)+0.5D0*dxj
14378           yj=c(2,j)+0.5D0*dyj
14379           zj=c(3,j)+0.5D0*dzj
14380           xj=mod(xj,boxxsize)
14381           if (xj.lt.0) xj=xj+boxxsize
14382           yj=mod(yj,boxysize)
14383           if (yj.lt.0) yj=yj+boxysize
14384           zj=mod(zj,boxzsize)
14385           if (zj.lt.0) zj=zj+boxzsize
14386       isubchap=0
14387       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14388       xj_safe=xj
14389       yj_safe=yj
14390       zj_safe=zj
14391       do xshift=-1,1
14392       do yshift=-1,1
14393       do zshift=-1,1
14394           xj=xj_safe+xshift*boxxsize
14395           yj=yj_safe+yshift*boxysize
14396           zj=zj_safe+zshift*boxzsize
14397           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14398           if(dist_temp.lt.dist_init) then
14399             dist_init=dist_temp
14400             xj_temp=xj
14401             yj_temp=yj
14402             zj_temp=zj
14403             isubchap=1
14404           endif
14405        enddo
14406        enddo
14407        enddo
14408        if (isubchap.eq.1) then
14409 !C          print *,i,j
14410           xj=xj_temp-xmedi
14411           yj=yj_temp-ymedi
14412           zj=zj_temp-zmedi
14413        else
14414           xj=xj_safe-xmedi
14415           yj=yj_safe-ymedi
14416           zj=zj_safe-zmedi
14417        endif
14418
14419           rij=xj*xj+yj*yj+zj*zj
14420           rrmij=1.0D0/rij
14421           rij=dsqrt(rij)
14422           rmij=1.0D0/rij
14423 ! For extracting the short-range part of Evdwpp
14424           sss=sscale(rij/rpp(iteli,itelj))
14425             sss_ele_cut=sscale_ele(rij)
14426             sss_ele_grad=sscagrad_ele(rij)
14427             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14428 !             sss_ele_cut=1.0d0
14429 !             sss_ele_grad=0.0d0
14430             if (sss_ele_cut.le.0.0) go to 128
14431
14432           r3ij=rrmij*rmij
14433           r6ij=r3ij*r3ij
14434           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14435           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14436           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14437           fac=cosa-3.0D0*cosb*cosg
14438           ev1=aaa*r6ij*r6ij
14439 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14440           if (j.eq.i+2) ev1=scal_el*ev1
14441           ev2=bbb*r6ij
14442           fac3=ael6i*r6ij
14443           fac4=ael3i*r3ij
14444           evdwij=ev1+ev2
14445           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14446           el2=fac4*fac
14447           eesij=el1+el2
14448 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14449           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14450           ees=ees+eesij*sss_ele_cut
14451           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14452 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14453 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14454 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14455 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14456
14457           if (energy_dec) then
14458               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14459               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14460           endif
14461
14462 !
14463 ! Calculate contributions to the Cartesian gradient.
14464 !
14465 #ifdef SPLITELE
14466           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14467           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14468           fac1=fac
14469           erij(1)=xj*rmij
14470           erij(2)=yj*rmij
14471           erij(3)=zj*rmij
14472 !
14473 ! Radial derivatives. First process both termini of the fragment (i,j)
14474 !
14475           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14476           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14477           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14478 !          do k=1,3
14479 !            ghalf=0.5D0*ggg(k)
14480 !            gelc(k,i)=gelc(k,i)+ghalf
14481 !            gelc(k,j)=gelc(k,j)+ghalf
14482 !          enddo
14483 ! 9/28/08 AL Gradient compotents will be summed only at the end
14484           do k=1,3
14485             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14486             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14487           enddo
14488 !
14489 ! Loop over residues i+1 thru j-1.
14490 !
14491 !grad          do k=i+1,j-1
14492 !grad            do l=1,3
14493 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14494 !grad            enddo
14495 !grad          enddo
14496           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14497           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14498           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14499           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14500           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14501           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14502 !          do k=1,3
14503 !            ghalf=0.5D0*ggg(k)
14504 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14505 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14506 !          enddo
14507 ! 9/28/08 AL Gradient compotents will be summed only at the end
14508           do k=1,3
14509             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14510             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14511           enddo
14512 !
14513 ! Loop over residues i+1 thru j-1.
14514 !
14515 !grad          do k=i+1,j-1
14516 !grad            do l=1,3
14517 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14518 !grad            enddo
14519 !grad          enddo
14520 #else
14521           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14522           facel=(el1+eesij)*sss_ele_cut
14523           fac1=fac
14524           fac=-3*rrmij*(facvdw+facvdw+facel)
14525           erij(1)=xj*rmij
14526           erij(2)=yj*rmij
14527           erij(3)=zj*rmij
14528 !
14529 ! Radial derivatives. First process both termini of the fragment (i,j)
14530 !
14531           ggg(1)=fac*xj
14532           ggg(2)=fac*yj
14533           ggg(3)=fac*zj
14534 !          do k=1,3
14535 !            ghalf=0.5D0*ggg(k)
14536 !            gelc(k,i)=gelc(k,i)+ghalf
14537 !            gelc(k,j)=gelc(k,j)+ghalf
14538 !          enddo
14539 ! 9/28/08 AL Gradient compotents will be summed only at the end
14540           do k=1,3
14541             gelc_long(k,j)=gelc(k,j)+ggg(k)
14542             gelc_long(k,i)=gelc(k,i)-ggg(k)
14543           enddo
14544 !
14545 ! Loop over residues i+1 thru j-1.
14546 !
14547 !grad          do k=i+1,j-1
14548 !grad            do l=1,3
14549 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14550 !grad            enddo
14551 !grad          enddo
14552 ! 9/28/08 AL Gradient compotents will be summed only at the end
14553           ggg(1)=facvdw*xj
14554           ggg(2)=facvdw*yj
14555           ggg(3)=facvdw*zj
14556           do k=1,3
14557             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14558             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14559           enddo
14560 #endif
14561 !
14562 ! Angular part
14563 !
14564           ecosa=2.0D0*fac3*fac1+fac4
14565           fac4=-3.0D0*fac4
14566           fac3=-6.0D0*fac3
14567           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14568           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14569           do k=1,3
14570             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14571             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14572           enddo
14573 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14574 !d   &          (dcosg(k),k=1,3)
14575           do k=1,3
14576             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14577           enddo
14578 !          do k=1,3
14579 !            ghalf=0.5D0*ggg(k)
14580 !            gelc(k,i)=gelc(k,i)+ghalf
14581 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14582 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14583 !            gelc(k,j)=gelc(k,j)+ghalf
14584 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14585 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14586 !          enddo
14587 !grad          do k=i+1,j-1
14588 !grad            do l=1,3
14589 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14590 !grad            enddo
14591 !grad          enddo
14592           do k=1,3
14593             gelc(k,i)=gelc(k,i) &
14594                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14595                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
14596                      *sss_ele_cut
14597             gelc(k,j)=gelc(k,j) &
14598                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14599                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14600                      *sss_ele_cut
14601             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14602             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14603           enddo
14604           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14605               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
14606               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14607 !
14608 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
14609 !   energy of a peptide unit is assumed in the form of a second-order
14610 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
14611 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
14612 !   are computed for EVERY pair of non-contiguous peptide groups.
14613 !
14614           if (j.lt.nres-1) then
14615             j1=j+1
14616             j2=j-1
14617           else
14618             j1=j-1
14619             j2=j-2
14620           endif
14621           kkk=0
14622           do k=1,2
14623             do l=1,2
14624               kkk=kkk+1
14625               muij(kkk)=mu(k,i)*mu(l,j)
14626             enddo
14627           enddo
14628 !d         write (iout,*) 'EELEC: i',i,' j',j
14629 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
14630 !d          write(iout,*) 'muij',muij
14631           ury=scalar(uy(1,i),erij)
14632           urz=scalar(uz(1,i),erij)
14633           vry=scalar(uy(1,j),erij)
14634           vrz=scalar(uz(1,j),erij)
14635           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
14636           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
14637           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
14638           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
14639           fac=dsqrt(-ael6i)*r3ij
14640           a22=a22*fac
14641           a23=a23*fac
14642           a32=a32*fac
14643           a33=a33*fac
14644 !d          write (iout,'(4i5,4f10.5)')
14645 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
14646 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
14647 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
14648 !d     &      uy(:,j),uz(:,j)
14649 !d          write (iout,'(4f10.5)')
14650 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
14651 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
14652 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
14653 !d           write (iout,'(9f10.5/)')
14654 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
14655 ! Derivatives of the elements of A in virtual-bond vectors
14656           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
14657           do k=1,3
14658             uryg(k,1)=scalar(erder(1,k),uy(1,i))
14659             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
14660             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
14661             urzg(k,1)=scalar(erder(1,k),uz(1,i))
14662             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
14663             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
14664             vryg(k,1)=scalar(erder(1,k),uy(1,j))
14665             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
14666             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
14667             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
14668             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
14669             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
14670           enddo
14671 ! Compute radial contributions to the gradient
14672           facr=-3.0d0*rrmij
14673           a22der=a22*facr
14674           a23der=a23*facr
14675           a32der=a32*facr
14676           a33der=a33*facr
14677           agg(1,1)=a22der*xj
14678           agg(2,1)=a22der*yj
14679           agg(3,1)=a22der*zj
14680           agg(1,2)=a23der*xj
14681           agg(2,2)=a23der*yj
14682           agg(3,2)=a23der*zj
14683           agg(1,3)=a32der*xj
14684           agg(2,3)=a32der*yj
14685           agg(3,3)=a32der*zj
14686           agg(1,4)=a33der*xj
14687           agg(2,4)=a33der*yj
14688           agg(3,4)=a33der*zj
14689 ! Add the contributions coming from er
14690           fac3=-3.0d0*fac
14691           do k=1,3
14692             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
14693             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
14694             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
14695             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
14696           enddo
14697           do k=1,3
14698 ! Derivatives in DC(i)
14699 !grad            ghalf1=0.5d0*agg(k,1)
14700 !grad            ghalf2=0.5d0*agg(k,2)
14701 !grad            ghalf3=0.5d0*agg(k,3)
14702 !grad            ghalf4=0.5d0*agg(k,4)
14703             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14704             -3.0d0*uryg(k,2)*vry)!+ghalf1
14705             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14706             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14707             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14708             -3.0d0*urzg(k,2)*vry)!+ghalf3
14709             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14710             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14711 ! Derivatives in DC(i+1)
14712             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14713             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14714             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14715             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14716             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14717             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14718             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14719             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14720 ! Derivatives in DC(j)
14721             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14722             -3.0d0*vryg(k,2)*ury)!+ghalf1
14723             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14724             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14725             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14726             -3.0d0*vryg(k,2)*urz)!+ghalf3
14727             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14728             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14729 ! Derivatives in DC(j+1) or DC(nres-1)
14730             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14731             -3.0d0*vryg(k,3)*ury)
14732             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14733             -3.0d0*vrzg(k,3)*ury)
14734             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14735             -3.0d0*vryg(k,3)*urz)
14736             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14737             -3.0d0*vrzg(k,3)*urz)
14738 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14739 !grad              do l=1,4
14740 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14741 !grad              enddo
14742 !grad            endif
14743           enddo
14744           acipa(1,1)=a22
14745           acipa(1,2)=a23
14746           acipa(2,1)=a32
14747           acipa(2,2)=a33
14748           a22=-a22
14749           a23=-a23
14750           do l=1,2
14751             do k=1,3
14752               agg(k,l)=-agg(k,l)
14753               aggi(k,l)=-aggi(k,l)
14754               aggi1(k,l)=-aggi1(k,l)
14755               aggj(k,l)=-aggj(k,l)
14756               aggj1(k,l)=-aggj1(k,l)
14757             enddo
14758           enddo
14759           if (j.lt.nres-1) then
14760             a22=-a22
14761             a32=-a32
14762             do l=1,3,2
14763               do k=1,3
14764                 agg(k,l)=-agg(k,l)
14765                 aggi(k,l)=-aggi(k,l)
14766                 aggi1(k,l)=-aggi1(k,l)
14767                 aggj(k,l)=-aggj(k,l)
14768                 aggj1(k,l)=-aggj1(k,l)
14769               enddo
14770             enddo
14771           else
14772             a22=-a22
14773             a23=-a23
14774             a32=-a32
14775             a33=-a33
14776             do l=1,4
14777               do k=1,3
14778                 agg(k,l)=-agg(k,l)
14779                 aggi(k,l)=-aggi(k,l)
14780                 aggi1(k,l)=-aggi1(k,l)
14781                 aggj(k,l)=-aggj(k,l)
14782                 aggj1(k,l)=-aggj1(k,l)
14783               enddo
14784             enddo
14785           endif
14786           ENDIF ! WCORR
14787           IF (wel_loc.gt.0.0d0) THEN
14788 ! Contribution to the local-electrostatic energy coming from the i-j pair
14789           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14790            +a33*muij(4)
14791 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14792 !           print *,"EELLOC",i,gel_loc_loc(i-1)
14793           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14794                   'eelloc',i,j,eel_loc_ij
14795 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14796
14797           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14798 ! Partial derivatives in virtual-bond dihedral angles gamma
14799           if (i.gt.1) &
14800           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14801                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14802                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14803                  *sss_ele_cut
14804           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14805                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14806                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14807                  *sss_ele_cut
14808            xtemp(1)=xj
14809            xtemp(2)=yj
14810            xtemp(3)=zj
14811
14812 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14813           do l=1,3
14814             ggg(l)=(agg(l,1)*muij(1)+ &
14815                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14816             *sss_ele_cut &
14817              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14818
14819             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14820             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14821 !grad            ghalf=0.5d0*ggg(l)
14822 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14823 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14824           enddo
14825 !grad          do k=i+1,j2
14826 !grad            do l=1,3
14827 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14828 !grad            enddo
14829 !grad          enddo
14830 ! Remaining derivatives of eello
14831           do l=1,3
14832             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14833                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14834             *sss_ele_cut
14835
14836             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14837                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14838             *sss_ele_cut
14839
14840             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14841                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14842             *sss_ele_cut
14843
14844             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14845                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14846             *sss_ele_cut
14847
14848           enddo
14849           ENDIF
14850 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14851 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14852           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14853              .and. num_conti.le.maxconts) then
14854 !            write (iout,*) i,j," entered corr"
14855 !
14856 ! Calculate the contact function. The ith column of the array JCONT will
14857 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14858 ! greater than I). The arrays FACONT and GACONT will contain the values of
14859 ! the contact function and its derivative.
14860 !           r0ij=1.02D0*rpp(iteli,itelj)
14861 !           r0ij=1.11D0*rpp(iteli,itelj)
14862             r0ij=2.20D0*rpp(iteli,itelj)
14863 !           r0ij=1.55D0*rpp(iteli,itelj)
14864             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14865 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14866             if (fcont.gt.0.0D0) then
14867               num_conti=num_conti+1
14868               if (num_conti.gt.maxconts) then
14869 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14870                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14871                                ' will skip next contacts for this conf.',num_conti
14872               else
14873                 jcont_hb(num_conti,i)=j
14874 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14875 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14876                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14877                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14878 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14879 !  terms.
14880                 d_cont(num_conti,i)=rij
14881 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14882 !     --- Electrostatic-interaction matrix ---
14883                 a_chuj(1,1,num_conti,i)=a22
14884                 a_chuj(1,2,num_conti,i)=a23
14885                 a_chuj(2,1,num_conti,i)=a32
14886                 a_chuj(2,2,num_conti,i)=a33
14887 !     --- Gradient of rij
14888                 do kkk=1,3
14889                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14890                 enddo
14891                 kkll=0
14892                 do k=1,2
14893                   do l=1,2
14894                     kkll=kkll+1
14895                     do m=1,3
14896                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14897                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14898                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14899                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14900                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14901                     enddo
14902                   enddo
14903                 enddo
14904                 ENDIF
14905                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14906 ! Calculate contact energies
14907                 cosa4=4.0D0*cosa
14908                 wij=cosa-3.0D0*cosb*cosg
14909                 cosbg1=cosb+cosg
14910                 cosbg2=cosb-cosg
14911 !               fac3=dsqrt(-ael6i)/r0ij**3
14912                 fac3=dsqrt(-ael6i)*r3ij
14913 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14914                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14915                 if (ees0tmp.gt.0) then
14916                   ees0pij=dsqrt(ees0tmp)
14917                 else
14918                   ees0pij=0
14919                 endif
14920 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14921                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14922                 if (ees0tmp.gt.0) then
14923                   ees0mij=dsqrt(ees0tmp)
14924                 else
14925                   ees0mij=0
14926                 endif
14927 !               ees0mij=0.0D0
14928                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14929                      *sss_ele_cut
14930
14931                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14932                      *sss_ele_cut
14933
14934 ! Diagnostics. Comment out or remove after debugging!
14935 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14936 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14937 !               ees0m(num_conti,i)=0.0D0
14938 ! End diagnostics.
14939 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
14940 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
14941 ! Angular derivatives of the contact function
14942                 ees0pij1=fac3/ees0pij
14943                 ees0mij1=fac3/ees0mij
14944                 fac3p=-3.0D0*fac3*rrmij
14945                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
14946                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
14947 !               ees0mij1=0.0D0
14948                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
14949                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
14950                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
14951                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
14952                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
14953                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
14954                 ecosap=ecosa1+ecosa2
14955                 ecosbp=ecosb1+ecosb2
14956                 ecosgp=ecosg1+ecosg2
14957                 ecosam=ecosa1-ecosa2
14958                 ecosbm=ecosb1-ecosb2
14959                 ecosgm=ecosg1-ecosg2
14960 ! Diagnostics
14961 !               ecosap=ecosa1
14962 !               ecosbp=ecosb1
14963 !               ecosgp=ecosg1
14964 !               ecosam=0.0D0
14965 !               ecosbm=0.0D0
14966 !               ecosgm=0.0D0
14967 ! End diagnostics
14968                 facont_hb(num_conti,i)=fcont
14969                 fprimcont=fprimcont/rij
14970 !d              facont_hb(num_conti,i)=1.0D0
14971 ! Following line is for diagnostics.
14972 !d              fprimcont=0.0D0
14973                 do k=1,3
14974                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14975                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14976                 enddo
14977                 do k=1,3
14978                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
14979                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
14980                 enddo
14981 !                gggp(1)=gggp(1)+ees0pijp*xj
14982 !                gggp(2)=gggp(2)+ees0pijp*yj
14983 !                gggp(3)=gggp(3)+ees0pijp*zj
14984 !                gggm(1)=gggm(1)+ees0mijp*xj
14985 !                gggm(2)=gggm(2)+ees0mijp*yj
14986 !                gggm(3)=gggm(3)+ees0mijp*zj
14987                 gggp(1)=gggp(1)+ees0pijp*xj &
14988                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14989                 gggp(2)=gggp(2)+ees0pijp*yj &
14990                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14991                 gggp(3)=gggp(3)+ees0pijp*zj &
14992                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14993
14994                 gggm(1)=gggm(1)+ees0mijp*xj &
14995                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14996
14997                 gggm(2)=gggm(2)+ees0mijp*yj &
14998                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14999
15000                 gggm(3)=gggm(3)+ees0mijp*zj &
15001                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15002
15003 ! Derivatives due to the contact function
15004                 gacont_hbr(1,num_conti,i)=fprimcont*xj
15005                 gacont_hbr(2,num_conti,i)=fprimcont*yj
15006                 gacont_hbr(3,num_conti,i)=fprimcont*zj
15007                 do k=1,3
15008 !
15009 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
15010 !          following the change of gradient-summation algorithm.
15011 !
15012 !grad                  ghalfp=0.5D0*gggp(k)
15013 !grad                  ghalfm=0.5D0*gggm(k)
15014 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
15015 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15016 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15017 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
15018 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15019 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15020 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
15021 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
15022 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15023 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15024 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
15025 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15026 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15027 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
15028                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
15029                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15030                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15031                      *sss_ele_cut
15032
15033                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
15034                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15035                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15036                      *sss_ele_cut
15037
15038                   gacontp_hb3(k,num_conti,i)=gggp(k) &
15039                      *sss_ele_cut
15040
15041                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
15042                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15043                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15044                      *sss_ele_cut
15045
15046                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
15047                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15048                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
15049                      *sss_ele_cut
15050
15051                   gacontm_hb3(k,num_conti,i)=gggm(k) &
15052                      *sss_ele_cut
15053
15054                 enddo
15055               ENDIF ! wcorr
15056               endif  ! num_conti.le.maxconts
15057             endif  ! fcont.gt.0
15058           endif    ! j.gt.i+1
15059           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
15060             do k=1,4
15061               do l=1,3
15062                 ghalf=0.5d0*agg(l,k)
15063                 aggi(l,k)=aggi(l,k)+ghalf
15064                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
15065                 aggj(l,k)=aggj(l,k)+ghalf
15066               enddo
15067             enddo
15068             if (j.eq.nres-1 .and. i.lt.j-2) then
15069               do k=1,4
15070                 do l=1,3
15071                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
15072                 enddo
15073               enddo
15074             endif
15075           endif
15076  128      continue
15077 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
15078       return
15079       end subroutine eelecij_scale
15080 !-----------------------------------------------------------------------------
15081       subroutine evdwpp_short(evdw1)
15082 !
15083 ! Compute Evdwpp
15084 !
15085 !      implicit real*8 (a-h,o-z)
15086 !      include 'DIMENSIONS'
15087 !      include 'COMMON.CONTROL'
15088 !      include 'COMMON.IOUNITS'
15089 !      include 'COMMON.GEO'
15090 !      include 'COMMON.VAR'
15091 !      include 'COMMON.LOCAL'
15092 !      include 'COMMON.CHAIN'
15093 !      include 'COMMON.DERIV'
15094 !      include 'COMMON.INTERACT'
15095 !      include 'COMMON.CONTACTS'
15096 !      include 'COMMON.TORSION'
15097 !      include 'COMMON.VECTORS'
15098 !      include 'COMMON.FFIELD'
15099       real(kind=8),dimension(3) :: ggg
15100 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15101 #ifdef MOMENT
15102       real(kind=8) :: scal_el=1.0d0
15103 #else
15104       real(kind=8) :: scal_el=0.5d0
15105 #endif
15106 !el local variables
15107       integer :: i,j,k,iteli,itelj,num_conti,isubchap
15108       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
15109       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
15110                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15111                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
15112       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15113                     dist_temp, dist_init,sss_grad
15114       integer xshift,yshift,zshift
15115
15116
15117       evdw1=0.0D0
15118 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
15119 !     & " iatel_e_vdw",iatel_e_vdw
15120       call flush(iout)
15121       do i=iatel_s_vdw,iatel_e_vdw
15122         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
15123         dxi=dc(1,i)
15124         dyi=dc(2,i)
15125         dzi=dc(3,i)
15126         dx_normi=dc_norm(1,i)
15127         dy_normi=dc_norm(2,i)
15128         dz_normi=dc_norm(3,i)
15129         xmedi=c(1,i)+0.5d0*dxi
15130         ymedi=c(2,i)+0.5d0*dyi
15131         zmedi=c(3,i)+0.5d0*dzi
15132           xmedi=dmod(xmedi,boxxsize)
15133           if (xmedi.lt.0) xmedi=xmedi+boxxsize
15134           ymedi=dmod(ymedi,boxysize)
15135           if (ymedi.lt.0) ymedi=ymedi+boxysize
15136           zmedi=dmod(zmedi,boxzsize)
15137           if (zmedi.lt.0) zmedi=zmedi+boxzsize
15138         num_conti=0
15139 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
15140 !     &   ' ielend',ielend_vdw(i)
15141         call flush(iout)
15142         do j=ielstart_vdw(i),ielend_vdw(i)
15143           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15144 !el          ind=ind+1
15145           iteli=itel(i)
15146           itelj=itel(j)
15147           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15148           aaa=app(iteli,itelj)
15149           bbb=bpp(iteli,itelj)
15150           dxj=dc(1,j)
15151           dyj=dc(2,j)
15152           dzj=dc(3,j)
15153           dx_normj=dc_norm(1,j)
15154           dy_normj=dc_norm(2,j)
15155           dz_normj=dc_norm(3,j)
15156 !          xj=c(1,j)+0.5D0*dxj-xmedi
15157 !          yj=c(2,j)+0.5D0*dyj-ymedi
15158 !          zj=c(3,j)+0.5D0*dzj-zmedi
15159           xj=c(1,j)+0.5D0*dxj
15160           yj=c(2,j)+0.5D0*dyj
15161           zj=c(3,j)+0.5D0*dzj
15162           xj=mod(xj,boxxsize)
15163           if (xj.lt.0) xj=xj+boxxsize
15164           yj=mod(yj,boxysize)
15165           if (yj.lt.0) yj=yj+boxysize
15166           zj=mod(zj,boxzsize)
15167           if (zj.lt.0) zj=zj+boxzsize
15168       isubchap=0
15169       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15170       xj_safe=xj
15171       yj_safe=yj
15172       zj_safe=zj
15173       do xshift=-1,1
15174       do yshift=-1,1
15175       do zshift=-1,1
15176           xj=xj_safe+xshift*boxxsize
15177           yj=yj_safe+yshift*boxysize
15178           zj=zj_safe+zshift*boxzsize
15179           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15180           if(dist_temp.lt.dist_init) then
15181             dist_init=dist_temp
15182             xj_temp=xj
15183             yj_temp=yj
15184             zj_temp=zj
15185             isubchap=1
15186           endif
15187        enddo
15188        enddo
15189        enddo
15190        if (isubchap.eq.1) then
15191 !C          print *,i,j
15192           xj=xj_temp-xmedi
15193           yj=yj_temp-ymedi
15194           zj=zj_temp-zmedi
15195        else
15196           xj=xj_safe-xmedi
15197           yj=yj_safe-ymedi
15198           zj=zj_safe-zmedi
15199        endif
15200
15201           rij=xj*xj+yj*yj+zj*zj
15202           rrmij=1.0D0/rij
15203           rij=dsqrt(rij)
15204           sss=sscale(rij/rpp(iteli,itelj))
15205             sss_ele_cut=sscale_ele(rij)
15206             sss_ele_grad=sscagrad_ele(rij)
15207             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15208             if (sss_ele_cut.le.0.0) cycle
15209           if (sss.gt.0.0d0) then
15210             rmij=1.0D0/rij
15211             r3ij=rrmij*rmij
15212             r6ij=r3ij*r3ij
15213             ev1=aaa*r6ij*r6ij
15214 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15215             if (j.eq.i+2) ev1=scal_el*ev1
15216             ev2=bbb*r6ij
15217             evdwij=ev1+ev2
15218             if (energy_dec) then
15219               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15220             endif
15221             evdw1=evdw1+evdwij*sss*sss_ele_cut
15222 !
15223 ! Calculate contributions to the Cartesian gradient.
15224 !
15225             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15226 !            ggg(1)=facvdw*xj
15227 !            ggg(2)=facvdw*yj
15228 !            ggg(3)=facvdw*zj
15229           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15230           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15231           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15232           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15233           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15234           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15235
15236             do k=1,3
15237               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15238               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15239             enddo
15240           endif
15241         enddo ! j
15242       enddo   ! i
15243       return
15244       end subroutine evdwpp_short
15245 !-----------------------------------------------------------------------------
15246       subroutine escp_long(evdw2,evdw2_14)
15247 !
15248 ! This subroutine calculates the excluded-volume interaction energy between
15249 ! peptide-group centers and side chains and its gradient in virtual-bond and
15250 ! side-chain vectors.
15251 !
15252 !      implicit real*8 (a-h,o-z)
15253 !      include 'DIMENSIONS'
15254 !      include 'COMMON.GEO'
15255 !      include 'COMMON.VAR'
15256 !      include 'COMMON.LOCAL'
15257 !      include 'COMMON.CHAIN'
15258 !      include 'COMMON.DERIV'
15259 !      include 'COMMON.INTERACT'
15260 !      include 'COMMON.FFIELD'
15261 !      include 'COMMON.IOUNITS'
15262 !      include 'COMMON.CONTROL'
15263       real(kind=8),dimension(3) :: ggg
15264 !el local variables
15265       integer :: i,iint,j,k,iteli,itypj,subchap
15266       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15267       real(kind=8) :: evdw2,evdw2_14,evdwij
15268       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15269                     dist_temp, dist_init
15270
15271       evdw2=0.0D0
15272       evdw2_14=0.0d0
15273 !d    print '(a)','Enter ESCP'
15274 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15275       do i=iatscp_s,iatscp_e
15276         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15277         iteli=itel(i)
15278         xi=0.5D0*(c(1,i)+c(1,i+1))
15279         yi=0.5D0*(c(2,i)+c(2,i+1))
15280         zi=0.5D0*(c(3,i)+c(3,i+1))
15281           xi=mod(xi,boxxsize)
15282           if (xi.lt.0) xi=xi+boxxsize
15283           yi=mod(yi,boxysize)
15284           if (yi.lt.0) yi=yi+boxysize
15285           zi=mod(zi,boxzsize)
15286           if (zi.lt.0) zi=zi+boxzsize
15287
15288         do iint=1,nscp_gr(i)
15289
15290         do j=iscpstart(i,iint),iscpend(i,iint)
15291           itypj=itype(j,1)
15292           if (itypj.eq.ntyp1) cycle
15293 ! Uncomment following three lines for SC-p interactions
15294 !         xj=c(1,nres+j)-xi
15295 !         yj=c(2,nres+j)-yi
15296 !         zj=c(3,nres+j)-zi
15297 ! Uncomment following three lines for Ca-p interactions
15298           xj=c(1,j)
15299           yj=c(2,j)
15300           zj=c(3,j)
15301           xj=mod(xj,boxxsize)
15302           if (xj.lt.0) xj=xj+boxxsize
15303           yj=mod(yj,boxysize)
15304           if (yj.lt.0) yj=yj+boxysize
15305           zj=mod(zj,boxzsize)
15306           if (zj.lt.0) zj=zj+boxzsize
15307       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15308       xj_safe=xj
15309       yj_safe=yj
15310       zj_safe=zj
15311       subchap=0
15312       do xshift=-1,1
15313       do yshift=-1,1
15314       do zshift=-1,1
15315           xj=xj_safe+xshift*boxxsize
15316           yj=yj_safe+yshift*boxysize
15317           zj=zj_safe+zshift*boxzsize
15318           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15319           if(dist_temp.lt.dist_init) then
15320             dist_init=dist_temp
15321             xj_temp=xj
15322             yj_temp=yj
15323             zj_temp=zj
15324             subchap=1
15325           endif
15326        enddo
15327        enddo
15328        enddo
15329        if (subchap.eq.1) then
15330           xj=xj_temp-xi
15331           yj=yj_temp-yi
15332           zj=zj_temp-zi
15333        else
15334           xj=xj_safe-xi
15335           yj=yj_safe-yi
15336           zj=zj_safe-zi
15337        endif
15338           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15339
15340           rij=dsqrt(1.0d0/rrij)
15341             sss_ele_cut=sscale_ele(rij)
15342             sss_ele_grad=sscagrad_ele(rij)
15343 !            print *,sss_ele_cut,sss_ele_grad,&
15344 !            (rij),r_cut_ele,rlamb_ele
15345             if (sss_ele_cut.le.0.0) cycle
15346           sss=sscale((rij/rscp(itypj,iteli)))
15347           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15348           if (sss.lt.1.0d0) then
15349
15350             fac=rrij**expon2
15351             e1=fac*fac*aad(itypj,iteli)
15352             e2=fac*bad(itypj,iteli)
15353             if (iabs(j-i) .le. 2) then
15354               e1=scal14*e1
15355               e2=scal14*e2
15356               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15357             endif
15358             evdwij=e1+e2
15359             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15360             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15361                 'evdw2',i,j,sss,evdwij
15362 !
15363 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15364 !
15365             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15366             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15367             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15368             ggg(1)=xj*fac
15369             ggg(2)=yj*fac
15370             ggg(3)=zj*fac
15371 ! Uncomment following three lines for SC-p interactions
15372 !           do k=1,3
15373 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15374 !           enddo
15375 ! Uncomment following line for SC-p interactions
15376 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15377             do k=1,3
15378               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15379               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15380             enddo
15381           endif
15382         enddo
15383
15384         enddo ! iint
15385       enddo ! i
15386       do i=1,nct
15387         do j=1,3
15388           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15389           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15390           gradx_scp(j,i)=expon*gradx_scp(j,i)
15391         enddo
15392       enddo
15393 !******************************************************************************
15394 !
15395 !                              N O T E !!!
15396 !
15397 ! To save time the factor EXPON has been extracted from ALL components
15398 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15399 ! use!
15400 !
15401 !******************************************************************************
15402       return
15403       end subroutine escp_long
15404 !-----------------------------------------------------------------------------
15405       subroutine escp_short(evdw2,evdw2_14)
15406 !
15407 ! This subroutine calculates the excluded-volume interaction energy between
15408 ! peptide-group centers and side chains and its gradient in virtual-bond and
15409 ! side-chain vectors.
15410 !
15411 !      implicit real*8 (a-h,o-z)
15412 !      include 'DIMENSIONS'
15413 !      include 'COMMON.GEO'
15414 !      include 'COMMON.VAR'
15415 !      include 'COMMON.LOCAL'
15416 !      include 'COMMON.CHAIN'
15417 !      include 'COMMON.DERIV'
15418 !      include 'COMMON.INTERACT'
15419 !      include 'COMMON.FFIELD'
15420 !      include 'COMMON.IOUNITS'
15421 !      include 'COMMON.CONTROL'
15422       real(kind=8),dimension(3) :: ggg
15423 !el local variables
15424       integer :: i,iint,j,k,iteli,itypj,subchap
15425       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15426       real(kind=8) :: evdw2,evdw2_14,evdwij
15427       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15428                     dist_temp, dist_init
15429
15430       evdw2=0.0D0
15431       evdw2_14=0.0d0
15432 !d    print '(a)','Enter ESCP'
15433 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15434       do i=iatscp_s,iatscp_e
15435         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15436         iteli=itel(i)
15437         xi=0.5D0*(c(1,i)+c(1,i+1))
15438         yi=0.5D0*(c(2,i)+c(2,i+1))
15439         zi=0.5D0*(c(3,i)+c(3,i+1))
15440           xi=mod(xi,boxxsize)
15441           if (xi.lt.0) xi=xi+boxxsize
15442           yi=mod(yi,boxysize)
15443           if (yi.lt.0) yi=yi+boxysize
15444           zi=mod(zi,boxzsize)
15445           if (zi.lt.0) zi=zi+boxzsize
15446
15447         do iint=1,nscp_gr(i)
15448
15449         do j=iscpstart(i,iint),iscpend(i,iint)
15450           itypj=itype(j,1)
15451           if (itypj.eq.ntyp1) cycle
15452 ! Uncomment following three lines for SC-p interactions
15453 !         xj=c(1,nres+j)-xi
15454 !         yj=c(2,nres+j)-yi
15455 !         zj=c(3,nres+j)-zi
15456 ! Uncomment following three lines for Ca-p interactions
15457 !          xj=c(1,j)-xi
15458 !          yj=c(2,j)-yi
15459 !          zj=c(3,j)-zi
15460           xj=c(1,j)
15461           yj=c(2,j)
15462           zj=c(3,j)
15463           xj=mod(xj,boxxsize)
15464           if (xj.lt.0) xj=xj+boxxsize
15465           yj=mod(yj,boxysize)
15466           if (yj.lt.0) yj=yj+boxysize
15467           zj=mod(zj,boxzsize)
15468           if (zj.lt.0) zj=zj+boxzsize
15469       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15470       xj_safe=xj
15471       yj_safe=yj
15472       zj_safe=zj
15473       subchap=0
15474       do xshift=-1,1
15475       do yshift=-1,1
15476       do zshift=-1,1
15477           xj=xj_safe+xshift*boxxsize
15478           yj=yj_safe+yshift*boxysize
15479           zj=zj_safe+zshift*boxzsize
15480           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15481           if(dist_temp.lt.dist_init) then
15482             dist_init=dist_temp
15483             xj_temp=xj
15484             yj_temp=yj
15485             zj_temp=zj
15486             subchap=1
15487           endif
15488        enddo
15489        enddo
15490        enddo
15491        if (subchap.eq.1) then
15492           xj=xj_temp-xi
15493           yj=yj_temp-yi
15494           zj=zj_temp-zi
15495        else
15496           xj=xj_safe-xi
15497           yj=yj_safe-yi
15498           zj=zj_safe-zi
15499        endif
15500
15501           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15502           rij=dsqrt(1.0d0/rrij)
15503             sss_ele_cut=sscale_ele(rij)
15504             sss_ele_grad=sscagrad_ele(rij)
15505 !            print *,sss_ele_cut,sss_ele_grad,&
15506 !            (rij),r_cut_ele,rlamb_ele
15507             if (sss_ele_cut.le.0.0) cycle
15508           sss=sscale(rij/rscp(itypj,iteli))
15509           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15510           if (sss.gt.0.0d0) then
15511
15512             fac=rrij**expon2
15513             e1=fac*fac*aad(itypj,iteli)
15514             e2=fac*bad(itypj,iteli)
15515             if (iabs(j-i) .le. 2) then
15516               e1=scal14*e1
15517               e2=scal14*e2
15518               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15519             endif
15520             evdwij=e1+e2
15521             evdw2=evdw2+evdwij*sss*sss_ele_cut
15522             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15523                 'evdw2',i,j,sss,evdwij
15524 !
15525 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15526 !
15527             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15528             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15529             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15530
15531             ggg(1)=xj*fac
15532             ggg(2)=yj*fac
15533             ggg(3)=zj*fac
15534 ! Uncomment following three lines for SC-p interactions
15535 !           do k=1,3
15536 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15537 !           enddo
15538 ! Uncomment following line for SC-p interactions
15539 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15540             do k=1,3
15541               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15542               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15543             enddo
15544           endif
15545         enddo
15546
15547         enddo ! iint
15548       enddo ! i
15549       do i=1,nct
15550         do j=1,3
15551           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15552           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15553           gradx_scp(j,i)=expon*gradx_scp(j,i)
15554         enddo
15555       enddo
15556 !******************************************************************************
15557 !
15558 !                              N O T E !!!
15559 !
15560 ! To save time the factor EXPON has been extracted from ALL components
15561 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15562 ! use!
15563 !
15564 !******************************************************************************
15565       return
15566       end subroutine escp_short
15567 !-----------------------------------------------------------------------------
15568 ! energy_p_new-sep_barrier.F
15569 !-----------------------------------------------------------------------------
15570       subroutine sc_grad_scale(scalfac)
15571 !      implicit real*8 (a-h,o-z)
15572       use calc_data
15573 !      include 'DIMENSIONS'
15574 !      include 'COMMON.CHAIN'
15575 !      include 'COMMON.DERIV'
15576 !      include 'COMMON.CALC'
15577 !      include 'COMMON.IOUNITS'
15578       real(kind=8),dimension(3) :: dcosom1,dcosom2
15579       real(kind=8) :: scalfac
15580 !el local variables
15581 !      integer :: i,j,k,l
15582
15583       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15584       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15585       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15586            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15587 ! diagnostics only
15588 !      eom1=0.0d0
15589 !      eom2=0.0d0
15590 !      eom12=evdwij*eps1_om12
15591 ! end diagnostics
15592 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15593 !     &  " sigder",sigder
15594 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15595 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15596       do k=1,3
15597         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15598         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15599       enddo
15600       do k=1,3
15601         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15602          *sss_ele_cut
15603       enddo
15604 !      write (iout,*) "gg",(gg(k),k=1,3)
15605       do k=1,3
15606         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15607                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15608                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15609                  *sss_ele_cut
15610         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15611                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15612                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15613          *sss_ele_cut
15614 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15615 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15616 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15617 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15618       enddo
15619 !
15620 ! Calculate the components of the gradient in DC and X
15621 !
15622       do l=1,3
15623         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15624         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15625       enddo
15626       return
15627       end subroutine sc_grad_scale
15628 !-----------------------------------------------------------------------------
15629 ! energy_split-sep.F
15630 !-----------------------------------------------------------------------------
15631       subroutine etotal_long(energia)
15632 !
15633 ! Compute the long-range slow-varying contributions to the energy
15634 !
15635 !      implicit real*8 (a-h,o-z)
15636 !      include 'DIMENSIONS'
15637       use MD_data, only: totT,usampl,eq_time
15638 #ifndef ISNAN
15639       external proc_proc
15640 #ifdef WINPGI
15641 !MS$ATTRIBUTES C ::  proc_proc
15642 #endif
15643 #endif
15644 #ifdef MPI
15645       include "mpif.h"
15646       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15647 #endif
15648 !      include 'COMMON.SETUP'
15649 !      include 'COMMON.IOUNITS'
15650 !      include 'COMMON.FFIELD'
15651 !      include 'COMMON.DERIV'
15652 !      include 'COMMON.INTERACT'
15653 !      include 'COMMON.SBRIDGE'
15654 !      include 'COMMON.CHAIN'
15655 !      include 'COMMON.VAR'
15656 !      include 'COMMON.LOCAL'
15657 !      include 'COMMON.MD'
15658       real(kind=8),dimension(0:n_ene) :: energia
15659 !el local variables
15660       integer :: i,n_corr,n_corr1,ierror,ierr
15661       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15662                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15663                   ecorr,ecorr5,ecorr6,eturn6,time00
15664 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15665 !elwrite(iout,*)"in etotal long"
15666
15667       if (modecalc.eq.12.or.modecalc.eq.14) then
15668 #ifdef MPI
15669 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15670 #else
15671         call int_from_cart1(.false.)
15672 #endif
15673       endif
15674 !elwrite(iout,*)"in etotal long"
15675
15676 #ifdef MPI
15677 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15678 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15679       call flush(iout)
15680       if (nfgtasks.gt.1) then
15681         time00=MPI_Wtime()
15682 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15683         if (fg_rank.eq.0) then
15684           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15685 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15686 !          call flush(iout)
15687 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15688 ! FG slaves as WEIGHTS array.
15689           weights_(1)=wsc
15690           weights_(2)=wscp
15691           weights_(3)=welec
15692           weights_(4)=wcorr
15693           weights_(5)=wcorr5
15694           weights_(6)=wcorr6
15695           weights_(7)=wel_loc
15696           weights_(8)=wturn3
15697           weights_(9)=wturn4
15698           weights_(10)=wturn6
15699           weights_(11)=wang
15700           weights_(12)=wscloc
15701           weights_(13)=wtor
15702           weights_(14)=wtor_d
15703           weights_(15)=wstrain
15704           weights_(16)=wvdwpp
15705           weights_(17)=wbond
15706           weights_(18)=scal14
15707           weights_(21)=wsccor
15708 ! FG Master broadcasts the WEIGHTS_ array
15709           call MPI_Bcast(weights_(1),n_ene,&
15710               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15711         else
15712 ! FG slaves receive the WEIGHTS array
15713           call MPI_Bcast(weights(1),n_ene,&
15714               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15715           wsc=weights(1)
15716           wscp=weights(2)
15717           welec=weights(3)
15718           wcorr=weights(4)
15719           wcorr5=weights(5)
15720           wcorr6=weights(6)
15721           wel_loc=weights(7)
15722           wturn3=weights(8)
15723           wturn4=weights(9)
15724           wturn6=weights(10)
15725           wang=weights(11)
15726           wscloc=weights(12)
15727           wtor=weights(13)
15728           wtor_d=weights(14)
15729           wstrain=weights(15)
15730           wvdwpp=weights(16)
15731           wbond=weights(17)
15732           scal14=weights(18)
15733           wsccor=weights(21)
15734         endif
15735         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15736           king,FG_COMM,IERR)
15737          time_Bcast=time_Bcast+MPI_Wtime()-time00
15738          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15739 !        call chainbuild_cart
15740 !        call int_from_cart1(.false.)
15741       endif
15742 !      write (iout,*) 'Processor',myrank,
15743 !     &  ' calling etotal_short ipot=',ipot
15744 !      call flush(iout)
15745 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15746 #endif
15747 !d    print *,'nnt=',nnt,' nct=',nct
15748 !
15749 !elwrite(iout,*)"in etotal long"
15750 ! Compute the side-chain and electrostatic interaction energy
15751 !
15752       goto (101,102,103,104,105,106) ipot
15753 ! Lennard-Jones potential.
15754   101 call elj_long(evdw)
15755 !d    print '(a)','Exit ELJ'
15756       goto 107
15757 ! Lennard-Jones-Kihara potential (shifted).
15758   102 call eljk_long(evdw)
15759       goto 107
15760 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15761   103 call ebp_long(evdw)
15762       goto 107
15763 ! Gay-Berne potential (shifted LJ, angular dependence).
15764   104 call egb_long(evdw)
15765       goto 107
15766 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15767   105 call egbv_long(evdw)
15768       goto 107
15769 ! Soft-sphere potential
15770   106 call e_softsphere(evdw)
15771 !
15772 ! Calculate electrostatic (H-bonding) energy of the main chain.
15773 !
15774   107 continue
15775       call vec_and_deriv
15776       if (ipot.lt.6) then
15777 #ifdef SPLITELE
15778          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15779              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15780              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15781              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15782 #else
15783          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15784              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15785              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15786              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15787 #endif
15788            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15789          else
15790             ees=0
15791             evdw1=0
15792             eel_loc=0
15793             eello_turn3=0
15794             eello_turn4=0
15795          endif
15796       else
15797 !        write (iout,*) "Soft-spheer ELEC potential"
15798         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15799          eello_turn4)
15800       endif
15801 !
15802 ! Calculate excluded-volume interaction energy between peptide groups
15803 ! and side chains.
15804 !
15805       if (ipot.lt.6) then
15806        if(wscp.gt.0d0) then
15807         call escp_long(evdw2,evdw2_14)
15808        else
15809         evdw2=0
15810         evdw2_14=0
15811        endif
15812       else
15813         call escp_soft_sphere(evdw2,evdw2_14)
15814       endif
15815 !
15816 ! 12/1/95 Multi-body terms
15817 !
15818       n_corr=0
15819       n_corr1=0
15820       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15821           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15822          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15823 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15824 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15825       else
15826          ecorr=0.0d0
15827          ecorr5=0.0d0
15828          ecorr6=0.0d0
15829          eturn6=0.0d0
15830       endif
15831       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15832          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15833       endif
15834 !
15835 ! If performing constraint dynamics, call the constraint energy
15836 !  after the equilibration time
15837       if(usampl.and.totT.gt.eq_time) then
15838          call EconstrQ
15839          call Econstr_back
15840       else
15841          Uconst=0.0d0
15842          Uconst_back=0.0d0
15843       endif
15844 !
15845 ! Sum the energies
15846 !
15847       do i=1,n_ene
15848         energia(i)=0.0d0
15849       enddo
15850       energia(1)=evdw
15851 #ifdef SCP14
15852       energia(2)=evdw2-evdw2_14
15853       energia(18)=evdw2_14
15854 #else
15855       energia(2)=evdw2
15856       energia(18)=0.0d0
15857 #endif
15858 #ifdef SPLITELE
15859       energia(3)=ees
15860       energia(16)=evdw1
15861 #else
15862       energia(3)=ees+evdw1
15863       energia(16)=0.0d0
15864 #endif
15865       energia(4)=ecorr
15866       energia(5)=ecorr5
15867       energia(6)=ecorr6
15868       energia(7)=eel_loc
15869       energia(8)=eello_turn3
15870       energia(9)=eello_turn4
15871       energia(10)=eturn6
15872       energia(20)=Uconst+Uconst_back
15873       call sum_energy(energia,.true.)
15874 !      write (iout,*) "Exit ETOTAL_LONG"
15875       call flush(iout)
15876       return
15877       end subroutine etotal_long
15878 !-----------------------------------------------------------------------------
15879       subroutine etotal_short(energia)
15880 !
15881 ! Compute the short-range fast-varying contributions to the energy
15882 !
15883 !      implicit real*8 (a-h,o-z)
15884 !      include 'DIMENSIONS'
15885 #ifndef ISNAN
15886       external proc_proc
15887 #ifdef WINPGI
15888 !MS$ATTRIBUTES C ::  proc_proc
15889 #endif
15890 #endif
15891 #ifdef MPI
15892       include "mpif.h"
15893       integer :: ierror,ierr
15894       real(kind=8),dimension(n_ene) :: weights_
15895       real(kind=8) :: time00
15896 #endif
15897 !      include 'COMMON.SETUP'
15898 !      include 'COMMON.IOUNITS'
15899 !      include 'COMMON.FFIELD'
15900 !      include 'COMMON.DERIV'
15901 !      include 'COMMON.INTERACT'
15902 !      include 'COMMON.SBRIDGE'
15903 !      include 'COMMON.CHAIN'
15904 !      include 'COMMON.VAR'
15905 !      include 'COMMON.LOCAL'
15906       real(kind=8),dimension(0:n_ene) :: energia
15907 !el local variables
15908       integer :: i,nres6
15909       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15910       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
15911       nres6=6*nres
15912
15913 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15914 !      call flush(iout)
15915       if (modecalc.eq.12.or.modecalc.eq.14) then
15916 #ifdef MPI
15917         if (fg_rank.eq.0) call int_from_cart1(.false.)
15918 #else
15919         call int_from_cart1(.false.)
15920 #endif
15921       endif
15922 #ifdef MPI
15923 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15924 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15925 !      call flush(iout)
15926       if (nfgtasks.gt.1) then
15927         time00=MPI_Wtime()
15928 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15929         if (fg_rank.eq.0) then
15930           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15931 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15932 !          call flush(iout)
15933 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15934 ! FG slaves as WEIGHTS array.
15935           weights_(1)=wsc
15936           weights_(2)=wscp
15937           weights_(3)=welec
15938           weights_(4)=wcorr
15939           weights_(5)=wcorr5
15940           weights_(6)=wcorr6
15941           weights_(7)=wel_loc
15942           weights_(8)=wturn3
15943           weights_(9)=wturn4
15944           weights_(10)=wturn6
15945           weights_(11)=wang
15946           weights_(12)=wscloc
15947           weights_(13)=wtor
15948           weights_(14)=wtor_d
15949           weights_(15)=wstrain
15950           weights_(16)=wvdwpp
15951           weights_(17)=wbond
15952           weights_(18)=scal14
15953           weights_(21)=wsccor
15954 ! FG Master broadcasts the WEIGHTS_ array
15955           call MPI_Bcast(weights_(1),n_ene,&
15956               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15957         else
15958 ! FG slaves receive the WEIGHTS array
15959           call MPI_Bcast(weights(1),n_ene,&
15960               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15961           wsc=weights(1)
15962           wscp=weights(2)
15963           welec=weights(3)
15964           wcorr=weights(4)
15965           wcorr5=weights(5)
15966           wcorr6=weights(6)
15967           wel_loc=weights(7)
15968           wturn3=weights(8)
15969           wturn4=weights(9)
15970           wturn6=weights(10)
15971           wang=weights(11)
15972           wscloc=weights(12)
15973           wtor=weights(13)
15974           wtor_d=weights(14)
15975           wstrain=weights(15)
15976           wvdwpp=weights(16)
15977           wbond=weights(17)
15978           scal14=weights(18)
15979           wsccor=weights(21)
15980         endif
15981 !        write (iout,*),"Processor",myrank," BROADCAST weights"
15982         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
15983           king,FG_COMM,IERR)
15984 !        write (iout,*) "Processor",myrank," BROADCAST c"
15985         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
15986           king,FG_COMM,IERR)
15987 !        write (iout,*) "Processor",myrank," BROADCAST dc"
15988         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
15989           king,FG_COMM,IERR)
15990 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
15991         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
15992           king,FG_COMM,IERR)
15993 !        write (iout,*) "Processor",myrank," BROADCAST theta"
15994         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
15995           king,FG_COMM,IERR)
15996 !        write (iout,*) "Processor",myrank," BROADCAST phi"
15997         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
15998           king,FG_COMM,IERR)
15999 !        write (iout,*) "Processor",myrank," BROADCAST alph"
16000         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
16001           king,FG_COMM,IERR)
16002 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
16003         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
16004           king,FG_COMM,IERR)
16005 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
16006         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
16007           king,FG_COMM,IERR)
16008          time_Bcast=time_Bcast+MPI_Wtime()-time00
16009 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
16010       endif
16011 !      write (iout,*) 'Processor',myrank,
16012 !     &  ' calling etotal_short ipot=',ipot
16013 !      call flush(iout)
16014 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16015 #endif
16016 !      call int_from_cart1(.false.)
16017 !
16018 ! Compute the side-chain and electrostatic interaction energy
16019 !
16020       goto (101,102,103,104,105,106) ipot
16021 ! Lennard-Jones potential.
16022   101 call elj_short(evdw)
16023 !d    print '(a)','Exit ELJ'
16024       goto 107
16025 ! Lennard-Jones-Kihara potential (shifted).
16026   102 call eljk_short(evdw)
16027       goto 107
16028 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16029   103 call ebp_short(evdw)
16030       goto 107
16031 ! Gay-Berne potential (shifted LJ, angular dependence).
16032   104 call egb_short(evdw)
16033       goto 107
16034 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16035   105 call egbv_short(evdw)
16036       goto 107
16037 ! Soft-sphere potential - already dealt with in the long-range part
16038   106 evdw=0.0d0
16039 !  106 call e_softsphere_short(evdw)
16040 !
16041 ! Calculate electrostatic (H-bonding) energy of the main chain.
16042 !
16043   107 continue
16044 !
16045 ! Calculate the short-range part of Evdwpp
16046 !
16047       call evdwpp_short(evdw1)
16048 !
16049 ! Calculate the short-range part of ESCp
16050 !
16051       if (ipot.lt.6) then
16052         call escp_short(evdw2,evdw2_14)
16053       endif
16054 !
16055 ! Calculate the bond-stretching energy
16056 !
16057       call ebond(estr)
16058 !
16059 ! Calculate the disulfide-bridge and other energy and the contributions
16060 ! from other distance constraints.
16061       call edis(ehpb)
16062 !
16063 ! Calculate the virtual-bond-angle energy.
16064 !
16065       call ebend(ebe,ethetacnstr)
16066 !
16067 ! Calculate the SC local energy.
16068 !
16069       call vec_and_deriv
16070       call esc(escloc)
16071 !
16072 ! Calculate the virtual-bond torsional energy.
16073 !
16074       call etor(etors,edihcnstr)
16075 !
16076 ! 6/23/01 Calculate double-torsional energy
16077 !
16078       call etor_d(etors_d)
16079 !
16080 ! 21/5/07 Calculate local sicdechain correlation energy
16081 !
16082       if (wsccor.gt.0.0d0) then
16083         call eback_sc_corr(esccor)
16084       else
16085         esccor=0.0d0
16086       endif
16087 !
16088 ! Put energy components into an array
16089 !
16090       do i=1,n_ene
16091         energia(i)=0.0d0
16092       enddo
16093       energia(1)=evdw
16094 #ifdef SCP14
16095       energia(2)=evdw2-evdw2_14
16096       energia(18)=evdw2_14
16097 #else
16098       energia(2)=evdw2
16099       energia(18)=0.0d0
16100 #endif
16101 #ifdef SPLITELE
16102       energia(16)=evdw1
16103 #else
16104       energia(3)=evdw1
16105 #endif
16106       energia(11)=ebe
16107       energia(12)=escloc
16108       energia(13)=etors
16109       energia(14)=etors_d
16110       energia(15)=ehpb
16111       energia(17)=estr
16112       energia(19)=edihcnstr
16113       energia(21)=esccor
16114 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
16115       call flush(iout)
16116       call sum_energy(energia,.true.)
16117 !      write (iout,*) "Exit ETOTAL_SHORT"
16118       call flush(iout)
16119       return
16120       end subroutine etotal_short
16121 !-----------------------------------------------------------------------------
16122 ! gnmr1.f
16123 !-----------------------------------------------------------------------------
16124       real(kind=8) function gnmr1(y,ymin,ymax)
16125 !      implicit none
16126       real(kind=8) :: y,ymin,ymax
16127       real(kind=8) :: wykl=4.0d0
16128       if (y.lt.ymin) then
16129         gnmr1=(ymin-y)**wykl/wykl
16130       else if (y.gt.ymax) then
16131         gnmr1=(y-ymax)**wykl/wykl
16132       else
16133         gnmr1=0.0d0
16134       endif
16135       return
16136       end function gnmr1
16137 !-----------------------------------------------------------------------------
16138       real(kind=8) function gnmr1prim(y,ymin,ymax)
16139 !      implicit none
16140       real(kind=8) :: y,ymin,ymax
16141       real(kind=8) :: wykl=4.0d0
16142       if (y.lt.ymin) then
16143         gnmr1prim=-(ymin-y)**(wykl-1)
16144       else if (y.gt.ymax) then
16145         gnmr1prim=(y-ymax)**(wykl-1)
16146       else
16147         gnmr1prim=0.0d0
16148       endif
16149       return
16150       end function gnmr1prim
16151 !----------------------------------------------------------------------------
16152       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16153       real(kind=8) y,ymin,ymax,sigma
16154       real(kind=8) wykl /4.0d0/
16155       if (y.lt.ymin) then
16156         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16157       else if (y.gt.ymax) then
16158         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16159       else
16160         rlornmr1=0.0d0
16161       endif
16162       return
16163       end function rlornmr1
16164 !------------------------------------------------------------------------------
16165       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16166       real(kind=8) y,ymin,ymax,sigma
16167       real(kind=8) wykl /4.0d0/
16168       if (y.lt.ymin) then
16169         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16170         ((ymin-y)**wykl+sigma**wykl)**2
16171       else if (y.gt.ymax) then
16172         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16173         ((y-ymax)**wykl+sigma**wykl)**2
16174       else
16175         rlornmr1prim=0.0d0
16176       endif
16177       return
16178       end function rlornmr1prim
16179
16180       real(kind=8) function harmonic(y,ymax)
16181 !      implicit none
16182       real(kind=8) :: y,ymax
16183       real(kind=8) :: wykl=2.0d0
16184       harmonic=(y-ymax)**wykl
16185       return
16186       end function harmonic
16187 !-----------------------------------------------------------------------------
16188       real(kind=8) function harmonicprim(y,ymax)
16189       real(kind=8) :: y,ymin,ymax
16190       real(kind=8) :: wykl=2.0d0
16191       harmonicprim=(y-ymax)*wykl
16192       return
16193       end function harmonicprim
16194 !-----------------------------------------------------------------------------
16195 ! gradient_p.F
16196 !-----------------------------------------------------------------------------
16197       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16198
16199       use io_base, only:intout,briefout
16200 !      implicit real*8 (a-h,o-z)
16201 !      include 'DIMENSIONS'
16202 !      include 'COMMON.CHAIN'
16203 !      include 'COMMON.DERIV'
16204 !      include 'COMMON.VAR'
16205 !      include 'COMMON.INTERACT'
16206 !      include 'COMMON.FFIELD'
16207 !      include 'COMMON.MD'
16208 !      include 'COMMON.IOUNITS'
16209       real(kind=8),external :: ufparm
16210       integer :: uiparm(1)
16211       real(kind=8) :: urparm(1)
16212       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16213       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16214       integer :: n,nf,ind,ind1,i,k,j
16215 !
16216 ! This subroutine calculates total internal coordinate gradient.
16217 ! Depending on the number of function evaluations, either whole energy
16218 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16219 ! internal coordinates are reevaluated or only the cartesian-in-internal
16220 ! coordinate derivatives are evaluated. The subroutine was designed to work
16221 ! with SUMSL.
16222 !
16223 !
16224       icg=mod(nf,2)+1
16225
16226 !d      print *,'grad',nf,icg
16227       if (nf-nfl+1) 20,30,40
16228    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16229 !    write (iout,*) 'grad 20'
16230       if (nf.eq.0) return
16231       goto 40
16232    30 call var_to_geom(n,x)
16233       call chainbuild
16234 !    write (iout,*) 'grad 30'
16235 !
16236 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16237 !
16238    40 call cartder
16239 !     write (iout,*) 'grad 40'
16240 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16241 !
16242 ! Convert the Cartesian gradient into internal-coordinate gradient.
16243 !
16244       ind=0
16245       ind1=0
16246       do i=1,nres-2
16247       gthetai=0.0D0
16248       gphii=0.0D0
16249       do j=i+1,nres-1
16250           ind=ind+1
16251 !         ind=indmat(i,j)
16252 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16253         do k=1,3
16254             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16255           enddo
16256         do k=1,3
16257           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16258           enddo
16259         enddo
16260       do j=i+1,nres-1
16261           ind1=ind1+1
16262 !         ind1=indmat(i,j)
16263 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16264         do k=1,3
16265           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16266           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16267           enddo
16268         enddo
16269       if (i.gt.1) g(i-1)=gphii
16270       if (n.gt.nphi) g(nphi+i)=gthetai
16271       enddo
16272       if (n.le.nphi+ntheta) goto 10
16273       do i=2,nres-1
16274       if (itype(i,1).ne.10) then
16275           galphai=0.0D0
16276         gomegai=0.0D0
16277         do k=1,3
16278           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16279           enddo
16280         do k=1,3
16281           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16282           enddo
16283           g(ialph(i,1))=galphai
16284         g(ialph(i,1)+nside)=gomegai
16285         endif
16286       enddo
16287 !
16288 ! Add the components corresponding to local energy terms.
16289 !
16290    10 continue
16291       do i=1,nvar
16292 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16293         g(i)=g(i)+gloc(i,icg)
16294       enddo
16295 ! Uncomment following three lines for diagnostics.
16296 !d    call intout
16297 !elwrite(iout,*) "in gradient after calling intout"
16298 !d    call briefout(0,0.0d0)
16299 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16300       return
16301       end subroutine gradient
16302 !-----------------------------------------------------------------------------
16303       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16304
16305       use comm_chu
16306 !      implicit real*8 (a-h,o-z)
16307 !      include 'DIMENSIONS'
16308 !      include 'COMMON.DERIV'
16309 !      include 'COMMON.IOUNITS'
16310 !      include 'COMMON.GEO'
16311       integer :: n,nf
16312 !el      integer :: jjj
16313 !el      common /chuju/ jjj
16314       real(kind=8) :: energia(0:n_ene)
16315       integer :: uiparm(1)
16316       real(kind=8) :: urparm(1)
16317       real(kind=8) :: f
16318       real(kind=8),external :: ufparm
16319       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16320 !     if (jjj.gt.0) then
16321 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16322 !     endif
16323       nfl=nf
16324       icg=mod(nf,2)+1
16325 !d      print *,'func',nf,nfl,icg
16326       call var_to_geom(n,x)
16327       call zerograd
16328       call chainbuild
16329 !d    write (iout,*) 'ETOTAL called from FUNC'
16330       call etotal(energia)
16331       call sum_gradient
16332       f=energia(0)
16333 !     if (jjj.gt.0) then
16334 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16335 !       write (iout,*) 'f=',etot
16336 !       jjj=0
16337 !     endif
16338       return
16339       end subroutine func
16340 !-----------------------------------------------------------------------------
16341       subroutine cartgrad
16342 !      implicit real*8 (a-h,o-z)
16343 !      include 'DIMENSIONS'
16344       use energy_data
16345       use MD_data, only: totT,usampl,eq_time
16346 #ifdef MPI
16347       include 'mpif.h'
16348 #endif
16349 !      include 'COMMON.CHAIN'
16350 !      include 'COMMON.DERIV'
16351 !      include 'COMMON.VAR'
16352 !      include 'COMMON.INTERACT'
16353 !      include 'COMMON.FFIELD'
16354 !      include 'COMMON.MD'
16355 !      include 'COMMON.IOUNITS'
16356 !      include 'COMMON.TIME1'
16357 !
16358       integer :: i,j
16359
16360 ! This subrouting calculates total Cartesian coordinate gradient.
16361 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16362 !
16363 !#define DEBUG
16364 #ifdef TIMING
16365       time00=MPI_Wtime()
16366 #endif
16367       icg=1
16368       call sum_gradient
16369 #ifdef TIMING
16370 #endif
16371 !#define DEBUG
16372 !el      write (iout,*) "After sum_gradient"
16373 #ifdef DEBUG
16374 !el      write (iout,*) "After sum_gradient"
16375       do i=1,nres-1
16376         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16377         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16378       enddo
16379 #endif
16380 !#undef DEBUG
16381 ! If performing constraint dynamics, add the gradients of the constraint energy
16382       if(usampl.and.totT.gt.eq_time) then
16383          do i=1,nct
16384            do j=1,3
16385              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
16386              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
16387            enddo
16388          enddo
16389          do i=1,nres-3
16390            gloc(i,icg)=gloc(i,icg)+dugamma(i)
16391          enddo
16392          do i=1,nres-2
16393            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
16394          enddo
16395       endif
16396 !elwrite (iout,*) "After sum_gradient"
16397 #ifdef TIMING
16398       time01=MPI_Wtime()
16399 #endif
16400       call intcartderiv
16401 !elwrite (iout,*) "After sum_gradient"
16402 #ifdef TIMING
16403       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
16404 #endif
16405 !     call checkintcartgrad
16406 !     write(iout,*) 'calling int_to_cart'
16407 !#define DEBUG
16408 #ifdef DEBUG
16409       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
16410 #endif
16411       do i=0,nct
16412         do j=1,3
16413           gcart(j,i)=gradc(j,i,icg)
16414           gxcart(j,i)=gradx(j,i,icg)
16415 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
16416         enddo
16417 #ifdef DEBUG
16418         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
16419           (gxcart(j,i),j=1,3),gloc(i,icg)
16420 #endif
16421       enddo
16422 #ifdef TIMING
16423       time01=MPI_Wtime()
16424 #endif
16425 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16426       call int_to_cart
16427 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16428
16429 #ifdef TIMING
16430             time_inttocart=time_inttocart+MPI_Wtime()-time01
16431 #endif
16432 #ifdef DEBUG
16433             write (iout,*) "gcart and gxcart after int_to_cart"
16434             do i=0,nres-1
16435             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16436                 (gxcart(j,i),j=1,3)
16437             enddo
16438 #endif
16439 !#undef DEBUG
16440 #ifdef CARGRAD
16441 #ifdef DEBUG
16442             write (iout,*) "CARGRAD"
16443 #endif
16444             do i=nres,0,-1
16445             do j=1,3
16446               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16447       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16448             enddo
16449       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16450       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16451             enddo
16452       ! Correction: dummy residues
16453             if (nnt.gt.1) then
16454               do j=1,3
16455       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16456                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16457               enddo
16458             endif
16459             if (nct.lt.nres) then
16460               do j=1,3
16461       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16462                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16463               enddo
16464             endif
16465 #endif
16466 #ifdef TIMING
16467             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16468 #endif
16469 !#undef DEBUG
16470             return
16471             end subroutine cartgrad
16472       !-----------------------------------------------------------------------------
16473             subroutine zerograd
16474       !      implicit real*8 (a-h,o-z)
16475       !      include 'DIMENSIONS'
16476       !      include 'COMMON.DERIV'
16477       !      include 'COMMON.CHAIN'
16478       !      include 'COMMON.VAR'
16479       !      include 'COMMON.MD'
16480       !      include 'COMMON.SCCOR'
16481       !
16482       !el local variables
16483             integer :: i,j,intertyp,k
16484       ! Initialize Cartesian-coordinate gradient
16485       !
16486       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16487       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16488
16489       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16490       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16491       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16492       !      allocate(gradcorr_long(3,nres))
16493       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16494       !      allocate(gcorr6_turn_long(3,nres))
16495       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16496
16497       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16498
16499       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16500       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16501
16502       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16503       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16504
16505       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16506       !      allocate(gscloc(3,nres)) !(3,maxres)
16507       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16508
16509
16510
16511       !      common /deriv_scloc/
16512       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16513       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16514       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
16515       !      common /mpgrad/
16516       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16517
16518
16519
16520       !          gradc(j,i,icg)=0.0d0
16521       !          gradx(j,i,icg)=0.0d0
16522
16523       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16524       !elwrite(iout,*) "icg",icg
16525             do i=-1,nres
16526             do j=1,3
16527               gvdwx(j,i)=0.0D0
16528               gradx_scp(j,i)=0.0D0
16529               gvdwc(j,i)=0.0D0
16530               gvdwc_scp(j,i)=0.0D0
16531               gvdwc_scpp(j,i)=0.0d0
16532               gelc(j,i)=0.0D0
16533               gelc_long(j,i)=0.0D0
16534               gradb(j,i)=0.0d0
16535               gradbx(j,i)=0.0d0
16536               gvdwpp(j,i)=0.0d0
16537               gel_loc(j,i)=0.0d0
16538               gel_loc_long(j,i)=0.0d0
16539               ghpbc(j,i)=0.0D0
16540               ghpbx(j,i)=0.0D0
16541               gcorr3_turn(j,i)=0.0d0
16542               gcorr4_turn(j,i)=0.0d0
16543               gradcorr(j,i)=0.0d0
16544               gradcorr_long(j,i)=0.0d0
16545               gradcorr5_long(j,i)=0.0d0
16546               gradcorr6_long(j,i)=0.0d0
16547               gcorr6_turn_long(j,i)=0.0d0
16548               gradcorr5(j,i)=0.0d0
16549               gradcorr6(j,i)=0.0d0
16550               gcorr6_turn(j,i)=0.0d0
16551               gsccorc(j,i)=0.0d0
16552               gsccorx(j,i)=0.0d0
16553               gradc(j,i,icg)=0.0d0
16554               gradx(j,i,icg)=0.0d0
16555               gscloc(j,i)=0.0d0
16556               gsclocx(j,i)=0.0d0
16557               gliptran(j,i)=0.0d0
16558               gliptranx(j,i)=0.0d0
16559               gliptranc(j,i)=0.0d0
16560               gshieldx(j,i)=0.0d0
16561               gshieldc(j,i)=0.0d0
16562               gshieldc_loc(j,i)=0.0d0
16563               gshieldx_ec(j,i)=0.0d0
16564               gshieldc_ec(j,i)=0.0d0
16565               gshieldc_loc_ec(j,i)=0.0d0
16566               gshieldx_t3(j,i)=0.0d0
16567               gshieldc_t3(j,i)=0.0d0
16568               gshieldc_loc_t3(j,i)=0.0d0
16569               gshieldx_t4(j,i)=0.0d0
16570               gshieldc_t4(j,i)=0.0d0
16571               gshieldc_loc_t4(j,i)=0.0d0
16572               gshieldx_ll(j,i)=0.0d0
16573               gshieldc_ll(j,i)=0.0d0
16574               gshieldc_loc_ll(j,i)=0.0d0
16575               gg_tube(j,i)=0.0d0
16576               gg_tube_sc(j,i)=0.0d0
16577               gradafm(j,i)=0.0d0
16578               gradb_nucl(j,i)=0.0d0
16579               gradbx_nucl(j,i)=0.0d0
16580               gvdwpp_nucl(j,i)=0.0d0
16581               gvdwpp(j,i)=0.0d0
16582               gelpp(j,i)=0.0d0
16583               gvdwpsb(j,i)=0.0d0
16584               gvdwpsb1(j,i)=0.0d0
16585               gvdwsbc(j,i)=0.0d0
16586               gvdwsbx(j,i)=0.0d0
16587               gelsbc(j,i)=0.0d0
16588               gradcorr_nucl(j,i)=0.0d0
16589               gradcorr3_nucl(j,i)=0.0d0
16590               gradxorr_nucl(j,i)=0.0d0
16591               gradxorr3_nucl(j,i)=0.0d0
16592               gelsbx(j,i)=0.0d0
16593               gsbloc(j,i)=0.0d0
16594               gsblocx(j,i)=0.0d0
16595               gradpepcat(j,i)=0.0d0
16596               gradpepcatx(j,i)=0.0d0
16597               gradcatcat(j,i)=0.0d0
16598               gvdwx_scbase(j,i)=0.0d0
16599               gvdwc_scbase(j,i)=0.0d0
16600               gvdwx_pepbase(j,i)=0.0d0
16601               gvdwc_pepbase(j,i)=0.0d0
16602               gvdwx_scpho(j,i)=0.0d0
16603               gvdwc_scpho(j,i)=0.0d0
16604               gvdwc_peppho(j,i)=0.0d0
16605             enddo
16606              enddo
16607             do i=0,nres
16608             do j=1,3
16609               do intertyp=1,3
16610                gloc_sc(intertyp,i,icg)=0.0d0
16611               enddo
16612             enddo
16613             enddo
16614             do i=1,nres
16615              do j=1,maxcontsshi
16616              shield_list(j,i)=0
16617             do k=1,3
16618       !C           print *,i,j,k
16619                grad_shield_side(k,j,i)=0.0d0
16620                grad_shield_loc(k,j,i)=0.0d0
16621              enddo
16622              enddo
16623              ishield_list(i)=0
16624             enddo
16625
16626       !
16627       ! Initialize the gradient of local energy terms.
16628       !
16629       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
16630       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16631       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16632       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
16633       !      allocate(gel_loc_turn3(nres))
16634       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16635       !      allocate(gsccor_loc(nres))      !(maxres)
16636
16637             do i=1,4*nres
16638             gloc(i,icg)=0.0D0
16639             enddo
16640             do i=1,nres
16641             gel_loc_loc(i)=0.0d0
16642             gcorr_loc(i)=0.0d0
16643             g_corr5_loc(i)=0.0d0
16644             g_corr6_loc(i)=0.0d0
16645             gel_loc_turn3(i)=0.0d0
16646             gel_loc_turn4(i)=0.0d0
16647             gel_loc_turn6(i)=0.0d0
16648             gsccor_loc(i)=0.0d0
16649             enddo
16650       ! initialize gcart and gxcart
16651       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16652             do i=0,nres
16653             do j=1,3
16654               gcart(j,i)=0.0d0
16655               gxcart(j,i)=0.0d0
16656             enddo
16657             enddo
16658             return
16659             end subroutine zerograd
16660       !-----------------------------------------------------------------------------
16661             real(kind=8) function fdum()
16662             fdum=0.0D0
16663             return
16664             end function fdum
16665       !-----------------------------------------------------------------------------
16666       ! intcartderiv.F
16667       !-----------------------------------------------------------------------------
16668             subroutine intcartderiv
16669       !      implicit real*8 (a-h,o-z)
16670       !      include 'DIMENSIONS'
16671 #ifdef MPI
16672             include 'mpif.h'
16673 #endif
16674       !      include 'COMMON.SETUP'
16675       !      include 'COMMON.CHAIN'
16676       !      include 'COMMON.VAR'
16677       !      include 'COMMON.GEO'
16678       !      include 'COMMON.INTERACT'
16679       !      include 'COMMON.DERIV'
16680       !      include 'COMMON.IOUNITS'
16681       !      include 'COMMON.LOCAL'
16682       !      include 'COMMON.SCCOR'
16683             real(kind=8) :: pi4,pi34
16684             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
16685             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
16686                       dcosomega,dsinomega !(3,3,maxres)
16687             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
16688
16689             integer :: i,j,k
16690             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
16691                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
16692                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
16693                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
16694             integer :: nres2
16695             nres2=2*nres
16696
16697       !el from module energy-------------
16698       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
16699       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
16700       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
16701
16702       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
16703       !el      allocate(dsintau(3,3,3,0:nres2))
16704       !el      allocate(dtauangle(3,3,3,0:nres2))
16705       !el      allocate(domicron(3,2,2,0:nres2))
16706       !el      allocate(dcosomicron(3,2,2,0:nres2))
16707
16708
16709
16710 #if defined(MPI) && defined(PARINTDER)
16711             if (nfgtasks.gt.1 .and. me.eq.king) &
16712             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
16713 #endif
16714             pi4 = 0.5d0*pipol
16715             pi34 = 3*pi4
16716
16717       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
16718       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
16719
16720       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
16721             do i=1,nres
16722             do j=1,3
16723               dtheta(j,1,i)=0.0d0
16724               dtheta(j,2,i)=0.0d0
16725               dphi(j,1,i)=0.0d0
16726               dphi(j,2,i)=0.0d0
16727               dphi(j,3,i)=0.0d0
16728             enddo
16729             enddo
16730       ! Derivatives of theta's
16731 #if defined(MPI) && defined(PARINTDER)
16732       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16733             do i=max0(ithet_start-1,3),ithet_end
16734 #else
16735             do i=3,nres
16736 #endif
16737             cost=dcos(theta(i))
16738             sint=sqrt(1-cost*cost)
16739             do j=1,3
16740               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
16741               vbld(i-1)
16742               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
16743               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
16744               vbld(i)
16745               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
16746             enddo
16747             enddo
16748 #if defined(MPI) && defined(PARINTDER)
16749       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16750             do i=max0(ithet_start-1,3),ithet_end
16751 #else
16752             do i=3,nres
16753 #endif
16754             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
16755             cost1=dcos(omicron(1,i))
16756             sint1=sqrt(1-cost1*cost1)
16757             cost2=dcos(omicron(2,i))
16758             sint2=sqrt(1-cost2*cost2)
16759              do j=1,3
16760       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
16761               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
16762               cost1*dc_norm(j,i-2))/ &
16763               vbld(i-1)
16764               domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
16765               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
16766               +cost1*(dc_norm(j,i-1+nres)))/ &
16767               vbld(i-1+nres)
16768               domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
16769       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
16770       !C Looks messy but better than if in loop
16771               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
16772               +cost2*dc_norm(j,i-1))/ &
16773               vbld(i)
16774               domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
16775               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16776                +cost2*(-dc_norm(j,i-1+nres)))/ &
16777               vbld(i-1+nres)
16778       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
16779               domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
16780             enddo
16781              endif
16782             enddo
16783       !elwrite(iout,*) "after vbld write"
16784       ! Derivatives of phi:
16785       ! If phi is 0 or 180 degrees, then the formulas
16786       ! have to be derived by power series expansion of the
16787       ! conventional formulas around 0 and 180.
16788 #ifdef PARINTDER
16789             do i=iphi1_start,iphi1_end
16790 #else
16791             do i=4,nres
16792 #endif
16793       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
16794       ! the conventional case
16795             sint=dsin(theta(i))
16796             sint1=dsin(theta(i-1))
16797             sing=dsin(phi(i))
16798             cost=dcos(theta(i))
16799             cost1=dcos(theta(i-1))
16800             cosg=dcos(phi(i))
16801             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16802             fac0=1.0d0/(sint1*sint)
16803             fac1=cost*fac0
16804             fac2=cost1*fac0
16805             fac3=cosg*cost1/(sint1*sint1)
16806             fac4=cosg*cost/(sint*sint)
16807       !    Obtaining the gamma derivatives from sine derivative
16808              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16809                phi(i).gt.pi34.and.phi(i).le.pi.or. &
16810                phi(i).ge.-pi.and.phi(i).le.-pi34) then
16811              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16812              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16813              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16814              do j=1,3
16815                 ctgt=cost/sint
16816                 ctgt1=cost1/sint1
16817                 cosg_inv=1.0d0/cosg
16818                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16819                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16820                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16821                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16822                 dsinphi(j,2,i)= &
16823                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16824                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16825                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16826                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16827                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16828       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16829                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16830                 endif
16831       ! Bug fixed 3/24/05 (AL)
16832              enddo
16833       !   Obtaining the gamma derivatives from cosine derivative
16834             else
16835                do j=1,3
16836                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16837                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16838                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16839                dc_norm(j,i-3))/vbld(i-2)
16840                dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
16841                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16842                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16843                dcostheta(j,1,i)
16844                dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
16845                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16846                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16847                dc_norm(j,i-1))/vbld(i)
16848                dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
16849 !#define DEBUG
16850 #ifdef DEBUG
16851                write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
16852 #endif
16853 !#undef DEBUG
16854                endif
16855              enddo
16856             endif
16857             enddo
16858       !alculate derivative of Tauangle
16859 #ifdef PARINTDER
16860             do i=itau_start,itau_end
16861 #else
16862             do i=3,nres
16863       !elwrite(iout,*) " vecpr",i,nres
16864 #endif
16865              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16866       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
16867       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
16868       !c dtauangle(j,intertyp,dervityp,residue number)
16869       !c INTERTYP=1 SC...Ca...Ca..Ca
16870       ! the conventional case
16871             sint=dsin(theta(i))
16872             sint1=dsin(omicron(2,i-1))
16873             sing=dsin(tauangle(1,i))
16874             cost=dcos(theta(i))
16875             cost1=dcos(omicron(2,i-1))
16876             cosg=dcos(tauangle(1,i))
16877       !elwrite(iout,*) " vecpr5",i,nres
16878             do j=1,3
16879       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16880       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16881             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16882       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16883             enddo
16884             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16885             fac0=1.0d0/(sint1*sint)
16886             fac1=cost*fac0
16887             fac2=cost1*fac0
16888             fac3=cosg*cost1/(sint1*sint1)
16889             fac4=cosg*cost/(sint*sint)
16890       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16891       !    Obtaining the gamma derivatives from sine derivative
16892              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16893                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16894                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16895              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16896              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16897              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16898             do j=1,3
16899                 ctgt=cost/sint
16900                 ctgt1=cost1/sint1
16901                 cosg_inv=1.0d0/cosg
16902                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16903              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16904              *vbld_inv(i-2+nres)
16905                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16906                 dsintau(j,1,2,i)= &
16907                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16908                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16909       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16910                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16911       ! Bug fixed 3/24/05 (AL)
16912                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16913                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16914       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16915                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16916              enddo
16917       !   Obtaining the gamma derivatives from cosine derivative
16918             else
16919                do j=1,3
16920                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16921                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16922                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16923                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16924                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16925                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16926                dcostheta(j,1,i)
16927                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16928                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16929                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16930                dc_norm(j,i-1))/vbld(i)
16931                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16932       !         write (iout,*) "else",i
16933              enddo
16934             endif
16935       !        do k=1,3
16936       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16937       !        enddo
16938             enddo
16939       !C Second case Ca...Ca...Ca...SC
16940 #ifdef PARINTDER
16941             do i=itau_start,itau_end
16942 #else
16943             do i=4,nres
16944 #endif
16945              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16946               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
16947       ! the conventional case
16948             sint=dsin(omicron(1,i))
16949             sint1=dsin(theta(i-1))
16950             sing=dsin(tauangle(2,i))
16951             cost=dcos(omicron(1,i))
16952             cost1=dcos(theta(i-1))
16953             cosg=dcos(tauangle(2,i))
16954       !        do j=1,3
16955       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16956       !        enddo
16957             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
16958             fac0=1.0d0/(sint1*sint)
16959             fac1=cost*fac0
16960             fac2=cost1*fac0
16961             fac3=cosg*cost1/(sint1*sint1)
16962             fac4=cosg*cost/(sint*sint)
16963       !    Obtaining the gamma derivatives from sine derivative
16964              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
16965                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
16966                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
16967              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
16968              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
16969              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16970             do j=1,3
16971                 ctgt=cost/sint
16972                 ctgt1=cost1/sint1
16973                 cosg_inv=1.0d0/cosg
16974                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16975                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
16976       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
16977       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
16978                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
16979                 dsintau(j,2,2,i)= &
16980                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
16981                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16982       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
16983       !     & sing*ctgt*domicron(j,1,2,i),
16984       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16985                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
16986       ! Bug fixed 3/24/05 (AL)
16987                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16988                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
16989       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16990                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
16991              enddo
16992       !   Obtaining the gamma derivatives from cosine derivative
16993             else
16994                do j=1,3
16995                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16996                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16997                dc_norm(j,i-3))/vbld(i-2)
16998                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
16999                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17000                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17001                dcosomicron(j,1,1,i)
17002                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
17003                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17004                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17005                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17006                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
17007       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
17008              enddo
17009             endif
17010             enddo
17011
17012       !CC third case SC...Ca...Ca...SC
17013 #ifdef PARINTDER
17014
17015             do i=itau_start,itau_end
17016 #else
17017             do i=3,nres
17018 #endif
17019       ! the conventional case
17020             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17021             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17022             sint=dsin(omicron(1,i))
17023             sint1=dsin(omicron(2,i-1))
17024             sing=dsin(tauangle(3,i))
17025             cost=dcos(omicron(1,i))
17026             cost1=dcos(omicron(2,i-1))
17027             cosg=dcos(tauangle(3,i))
17028             do j=1,3
17029             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17030       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17031             enddo
17032             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
17033             fac0=1.0d0/(sint1*sint)
17034             fac1=cost*fac0
17035             fac2=cost1*fac0
17036             fac3=cosg*cost1/(sint1*sint1)
17037             fac4=cosg*cost/(sint*sint)
17038       !    Obtaining the gamma derivatives from sine derivative
17039              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
17040                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
17041                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
17042              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
17043              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
17044              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17045             do j=1,3
17046                 ctgt=cost/sint
17047                 ctgt1=cost1/sint1
17048                 cosg_inv=1.0d0/cosg
17049                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17050                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
17051                   *vbld_inv(i-2+nres)
17052                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
17053                 dsintau(j,3,2,i)= &
17054                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
17055                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17056                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
17057       ! Bug fixed 3/24/05 (AL)
17058                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17059                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
17060                   *vbld_inv(i-1+nres)
17061       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17062                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
17063              enddo
17064       !   Obtaining the gamma derivatives from cosine derivative
17065             else
17066                do j=1,3
17067                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17068                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17069                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
17070                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
17071                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17072                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17073                dcosomicron(j,1,1,i)
17074                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
17075                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17076                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
17077                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17078                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
17079       !          write(iout,*) "else",i
17080              enddo
17081             endif
17082             enddo
17083
17084 #ifdef CRYST_SC
17085       !   Derivatives of side-chain angles alpha and omega
17086 #if defined(MPI) && defined(PARINTDER)
17087             do i=ibond_start,ibond_end
17088 #else
17089             do i=2,nres-1
17090 #endif
17091               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
17092                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
17093                  fac6=fac5/vbld(i)
17094                  fac7=fac5*fac5
17095                  fac8=fac5/vbld(i+1)
17096                  fac9=fac5/vbld(i+nres)
17097                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
17098                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
17099                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
17100                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
17101                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
17102                  sina=sqrt(1-cosa*cosa)
17103                  sino=dsin(omeg(i))
17104       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
17105                  do j=1,3
17106                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
17107                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
17108                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
17109                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
17110                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
17111                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
17112                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
17113                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
17114                   vbld(i+nres))
17115                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
17116                 enddo
17117       ! obtaining the derivatives of omega from sines
17118                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
17119                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
17120                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
17121                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
17122                    dsin(theta(i+1)))
17123                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
17124                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
17125                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
17126                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
17127                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
17128                    coso_inv=1.0d0/dcos(omeg(i))
17129                    do j=1,3
17130                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
17131                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
17132                    (sino*dc_norm(j,i-1))/vbld(i)
17133                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
17134                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
17135                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
17136                    -sino*dc_norm(j,i)/vbld(i+1)
17137                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
17138                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
17139                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
17140                    vbld(i+nres)
17141                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
17142                   enddo
17143                else
17144       !   obtaining the derivatives of omega from cosines
17145                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
17146                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
17147                  fac12=fac10*sina
17148                  fac13=fac12*fac12
17149                  fac14=sina*sina
17150                  do j=1,3
17151                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
17152                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
17153                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
17154                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
17155                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17156                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17157                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17158                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17159                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17160                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17161                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17162                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17163                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17164                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17165                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17166                 enddo
17167               endif
17168              else
17169                do j=1,3
17170                  do k=1,3
17171                    dalpha(k,j,i)=0.0d0
17172                    domega(k,j,i)=0.0d0
17173                  enddo
17174                enddo
17175              endif
17176              enddo
17177 #endif
17178 #if defined(MPI) && defined(PARINTDER)
17179             if (nfgtasks.gt.1) then
17180 #ifdef DEBUG
17181       !d      write (iout,*) "Gather dtheta"
17182       !d      call flush(iout)
17183             write (iout,*) "dtheta before gather"
17184             do i=1,nres
17185             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17186             enddo
17187 #endif
17188             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17189             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17190             king,FG_COMM,IERROR)
17191 !#define DEBUG
17192 #ifdef DEBUG
17193       !d      write (iout,*) "Gather dphi"
17194       !d      call flush(iout)
17195             write (iout,*) "dphi before gather"
17196             do i=1,nres
17197             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17198             enddo
17199 #endif
17200 !#undef DEBUG
17201             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17202             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17203             king,FG_COMM,IERROR)
17204       !d      write (iout,*) "Gather dalpha"
17205       !d      call flush(iout)
17206 #ifdef CRYST_SC
17207             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17208             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17209             king,FG_COMM,IERROR)
17210       !d      write (iout,*) "Gather domega"
17211       !d      call flush(iout)
17212             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17213             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17214             king,FG_COMM,IERROR)
17215 #endif
17216             endif
17217 #endif
17218 !#define DEBUG
17219 #ifdef DEBUG
17220             write (iout,*) "dtheta after gather"
17221             do i=1,nres
17222             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17223             enddo
17224             write (iout,*) "dphi after gather"
17225             do i=1,nres
17226             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17227             enddo
17228             write (iout,*) "dalpha after gather"
17229             do i=1,nres
17230             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17231             enddo
17232             write (iout,*) "domega after gather"
17233             do i=1,nres
17234             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17235             enddo
17236 #endif
17237 !#undef DEBUG
17238             return
17239             end subroutine intcartderiv
17240       !-----------------------------------------------------------------------------
17241             subroutine checkintcartgrad
17242       !      implicit real*8 (a-h,o-z)
17243       !      include 'DIMENSIONS'
17244 #ifdef MPI
17245             include 'mpif.h'
17246 #endif
17247       !      include 'COMMON.CHAIN'
17248       !      include 'COMMON.VAR'
17249       !      include 'COMMON.GEO'
17250       !      include 'COMMON.INTERACT'
17251       !      include 'COMMON.DERIV'
17252       !      include 'COMMON.IOUNITS'
17253       !      include 'COMMON.SETUP'
17254             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17255             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17256             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17257             real(kind=8),dimension(3) :: dc_norm_s
17258             real(kind=8) :: aincr=1.0d-5
17259             integer :: i,j
17260             real(kind=8) :: dcji
17261             do i=1,nres
17262             phi_s(i)=phi(i)
17263             theta_s(i)=theta(i)
17264             alph_s(i)=alph(i)
17265             omeg_s(i)=omeg(i)
17266             enddo
17267       ! Check theta gradient
17268             write (iout,*) &
17269              "Analytical (upper) and numerical (lower) gradient of theta"
17270             write (iout,*)
17271             do i=3,nres
17272             do j=1,3
17273               dcji=dc(j,i-2)
17274               dc(j,i-2)=dcji+aincr
17275               call chainbuild_cart
17276               call int_from_cart1(.false.)
17277           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17278           dc(j,i-2)=dcji
17279           dcji=dc(j,i-1)
17280           dc(j,i-1)=dc(j,i-1)+aincr
17281           call chainbuild_cart
17282           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17283           dc(j,i-1)=dcji
17284         enddo
17285 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17286 !el          (dtheta(j,2,i),j=1,3)
17287 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17288 !el          (dthetanum(j,2,i),j=1,3)
17289 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17290 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17291 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17292 !el        write (iout,*)
17293       enddo
17294 ! Check gamma gradient
17295       write (iout,*) &
17296        "Analytical (upper) and numerical (lower) gradient of gamma"
17297       do i=4,nres
17298         do j=1,3
17299           dcji=dc(j,i-3)
17300           dc(j,i-3)=dcji+aincr
17301           call chainbuild_cart
17302           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17303               dc(j,i-3)=dcji
17304           dcji=dc(j,i-2)
17305           dc(j,i-2)=dcji+aincr
17306           call chainbuild_cart
17307           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17308           dc(j,i-2)=dcji
17309           dcji=dc(j,i-1)
17310           dc(j,i-1)=dc(j,i-1)+aincr
17311           call chainbuild_cart
17312           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17313           dc(j,i-1)=dcji
17314         enddo
17315 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17316 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17317 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17318 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17319 !el        write (iout,'(5x,3(3f10.5,5x))') &
17320 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17321 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17322 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17323 !el        write (iout,*)
17324       enddo
17325 ! Check alpha gradient
17326       write (iout,*) &
17327        "Analytical (upper) and numerical (lower) gradient of alpha"
17328       do i=2,nres-1
17329        if(itype(i,1).ne.10) then
17330                  do j=1,3
17331                   dcji=dc(j,i-1)
17332                    dc(j,i-1)=dcji+aincr
17333               call chainbuild_cart
17334               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17335                  /aincr
17336                   dc(j,i-1)=dcji
17337               dcji=dc(j,i)
17338               dc(j,i)=dcji+aincr
17339               call chainbuild_cart
17340               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17341                  /aincr
17342               dc(j,i)=dcji
17343               dcji=dc(j,i+nres)
17344               dc(j,i+nres)=dc(j,i+nres)+aincr
17345               call chainbuild_cart
17346               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17347                  /aincr
17348              dc(j,i+nres)=dcji
17349             enddo
17350           endif
17351 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17352 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17353 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17354 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17355 !el        write (iout,'(5x,3(3f10.5,5x))') &
17356 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17357 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17358 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17359 !el        write (iout,*)
17360       enddo
17361 !     Check omega gradient
17362       write (iout,*) &
17363        "Analytical (upper) and numerical (lower) gradient of omega"
17364       do i=2,nres-1
17365        if(itype(i,1).ne.10) then
17366                  do j=1,3
17367                   dcji=dc(j,i-1)
17368                    dc(j,i-1)=dcji+aincr
17369               call chainbuild_cart
17370               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
17371                  /aincr
17372                   dc(j,i-1)=dcji
17373               dcji=dc(j,i)
17374               dc(j,i)=dcji+aincr
17375               call chainbuild_cart
17376               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
17377                  /aincr
17378               dc(j,i)=dcji
17379               dcji=dc(j,i+nres)
17380               dc(j,i+nres)=dc(j,i+nres)+aincr
17381               call chainbuild_cart
17382               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
17383                  /aincr
17384              dc(j,i+nres)=dcji
17385             enddo
17386           endif
17387 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
17388 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
17389 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
17390 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
17391 !el        write (iout,'(5x,3(3f10.5,5x))') &
17392 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
17393 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
17394 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
17395 !el        write (iout,*)
17396       enddo
17397       return
17398       end subroutine checkintcartgrad
17399 !-----------------------------------------------------------------------------
17400 ! q_measure.F
17401 !-----------------------------------------------------------------------------
17402       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
17403 !      implicit real*8 (a-h,o-z)
17404 !      include 'DIMENSIONS'
17405 !      include 'COMMON.IOUNITS'
17406 !      include 'COMMON.CHAIN'
17407 !      include 'COMMON.INTERACT'
17408 !      include 'COMMON.VAR'
17409       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
17410       integer :: kkk,nsep=3
17411       real(kind=8) :: qm      !dist,
17412       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
17413       logical :: lprn=.false.
17414       logical :: flag
17415 !      real(kind=8) :: sigm,x
17416
17417 !el      sigm(x)=0.25d0*x     ! local function
17418       qqmax=1.0d10
17419       do kkk=1,nperm
17420       qq = 0.0d0
17421       nl=0
17422        if(flag) then
17423         do il=seg1+nsep,seg2
17424           do jl=seg1,il-nsep
17425             nl=nl+1
17426             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
17427                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
17428                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17429             dij=dist(il,jl)
17430             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17431             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17432               nl=nl+1
17433               d0ijCM=dsqrt( &
17434                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17435                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17436                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17437               dijCM=dist(il+nres,jl+nres)
17438               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17439             endif
17440             qq = qq+qqij+qqijCM
17441           enddo
17442         enddo
17443         qq = qq/nl
17444       else
17445       do il=seg1,seg2
17446         if((seg3-il).lt.3) then
17447              secseg=il+3
17448         else
17449              secseg=seg3
17450         endif
17451           do jl=secseg,seg4
17452             nl=nl+1
17453             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17454                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17455                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17456             dij=dist(il,jl)
17457             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17458             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17459               nl=nl+1
17460               d0ijCM=dsqrt( &
17461                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17462                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17463                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17464               dijCM=dist(il+nres,jl+nres)
17465               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17466             endif
17467             qq = qq+qqij+qqijCM
17468           enddo
17469         enddo
17470       qq = qq/nl
17471       endif
17472       if (qqmax.le.qq) qqmax=qq
17473       enddo
17474       qwolynes=1.0d0-qqmax
17475       return
17476       end function qwolynes
17477 !-----------------------------------------------------------------------------
17478       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17479 !      implicit real*8 (a-h,o-z)
17480 !      include 'DIMENSIONS'
17481 !      include 'COMMON.IOUNITS'
17482 !      include 'COMMON.CHAIN'
17483 !      include 'COMMON.INTERACT'
17484 !      include 'COMMON.VAR'
17485 !      include 'COMMON.MD'
17486       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17487       integer :: nsep=3, kkk
17488 !el      real(kind=8) :: dist
17489       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17490       logical :: lprn=.false.
17491       logical :: flag
17492       real(kind=8) :: sim,dd0,fac,ddqij
17493 !el      sigm(x)=0.25d0*x           ! local function
17494       do kkk=1,nperm
17495       do i=0,nres
17496         do j=1,3
17497           dqwol(j,i)=0.0d0
17498           dxqwol(j,i)=0.0d0
17499         enddo
17500       enddo
17501       nl=0
17502        if(flag) then
17503         do il=seg1+nsep,seg2
17504           do jl=seg1,il-nsep
17505             nl=nl+1
17506             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17507                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17508                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17509             dij=dist(il,jl)
17510             sim = 1.0d0/sigm(d0ij)
17511             sim = sim*sim
17512             dd0 = dij-d0ij
17513             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17514           do k=1,3
17515               ddqij = (c(k,il)-c(k,jl))*fac
17516               dqwol(k,il)=dqwol(k,il)+ddqij
17517               dqwol(k,jl)=dqwol(k,jl)-ddqij
17518             enddo
17519
17520             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17521               nl=nl+1
17522               d0ijCM=dsqrt( &
17523                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17524                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17525                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17526               dijCM=dist(il+nres,jl+nres)
17527               sim = 1.0d0/sigm(d0ijCM)
17528               sim = sim*sim
17529               dd0=dijCM-d0ijCM
17530               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17531               do k=1,3
17532                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17533                 dxqwol(k,il)=dxqwol(k,il)+ddqij
17534                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17535               enddo
17536             endif
17537           enddo
17538         enddo
17539        else
17540         do il=seg1,seg2
17541         if((seg3-il).lt.3) then
17542              secseg=il+3
17543         else
17544              secseg=seg3
17545         endif
17546           do jl=secseg,seg4
17547             nl=nl+1
17548             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17549                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17550                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17551             dij=dist(il,jl)
17552             sim = 1.0d0/sigm(d0ij)
17553             sim = sim*sim
17554             dd0 = dij-d0ij
17555             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17556             do k=1,3
17557               ddqij = (c(k,il)-c(k,jl))*fac
17558               dqwol(k,il)=dqwol(k,il)+ddqij
17559               dqwol(k,jl)=dqwol(k,jl)-ddqij
17560             enddo
17561             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17562               nl=nl+1
17563               d0ijCM=dsqrt( &
17564                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17565                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17566                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17567               dijCM=dist(il+nres,jl+nres)
17568               sim = 1.0d0/sigm(d0ijCM)
17569               sim=sim*sim
17570               dd0 = dijCM-d0ijCM
17571               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17572               do k=1,3
17573                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17574                dxqwol(k,il)=dxqwol(k,il)+ddqij
17575                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17576               enddo
17577             endif
17578           enddo
17579         enddo
17580       endif
17581       enddo
17582        do i=0,nres
17583          do j=1,3
17584            dqwol(j,i)=dqwol(j,i)/nl
17585            dxqwol(j,i)=dxqwol(j,i)/nl
17586          enddo
17587        enddo
17588       return
17589       end subroutine qwolynes_prim
17590 !-----------------------------------------------------------------------------
17591       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17592 !      implicit real*8 (a-h,o-z)
17593 !      include 'DIMENSIONS'
17594 !      include 'COMMON.IOUNITS'
17595 !      include 'COMMON.CHAIN'
17596 !      include 'COMMON.INTERACT'
17597 !      include 'COMMON.VAR'
17598       integer :: seg1,seg2,seg3,seg4
17599       logical :: flag
17600       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17601       real(kind=8),dimension(3,0:2*nres) :: cdummy
17602       real(kind=8) :: q1,q2
17603       real(kind=8) :: delta=1.0d-10
17604       integer :: i,j
17605
17606       do i=0,nres
17607         do j=1,3
17608           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17609           cdummy(j,i)=c(j,i)
17610           c(j,i)=c(j,i)+delta
17611           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17612           qwolan(j,i)=(q2-q1)/delta
17613           c(j,i)=cdummy(j,i)
17614         enddo
17615       enddo
17616       do i=0,nres
17617         do j=1,3
17618           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17619           cdummy(j,i+nres)=c(j,i+nres)
17620           c(j,i+nres)=c(j,i+nres)+delta
17621           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17622           qwolxan(j,i)=(q2-q1)/delta
17623           c(j,i+nres)=cdummy(j,i+nres)
17624         enddo
17625       enddo
17626 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17627 !      do i=0,nct
17628 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17629 !      enddo
17630 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17631 !      do i=0,nct
17632 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17633 !      enddo
17634       return
17635       end subroutine qwol_num
17636 !-----------------------------------------------------------------------------
17637       subroutine EconstrQ
17638 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17639 !      implicit real*8 (a-h,o-z)
17640 !      include 'DIMENSIONS'
17641 !      include 'COMMON.CONTROL'
17642 !      include 'COMMON.VAR'
17643 !      include 'COMMON.MD'
17644       use MD_data
17645 !#ifndef LANG0
17646 !      include 'COMMON.LANGEVIN'
17647 !#else
17648 !      include 'COMMON.LANGEVIN.lang0'
17649 !#endif
17650 !      include 'COMMON.CHAIN'
17651 !      include 'COMMON.DERIV'
17652 !      include 'COMMON.GEO'
17653 !      include 'COMMON.LOCAL'
17654 !      include 'COMMON.INTERACT'
17655 !      include 'COMMON.IOUNITS'
17656 !      include 'COMMON.NAMES'
17657 !      include 'COMMON.TIME1'
17658       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
17659       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
17660                    duconst,duxconst
17661       integer :: kstart,kend,lstart,lend,idummy
17662       real(kind=8) :: delta=1.0d-7
17663       integer :: i,j,k,ii
17664       do i=0,nres
17665          do j=1,3
17666             duconst(j,i)=0.0d0
17667             dudconst(j,i)=0.0d0
17668             duxconst(j,i)=0.0d0
17669             dudxconst(j,i)=0.0d0
17670          enddo
17671       enddo
17672       Uconst=0.0d0
17673       do i=1,nfrag
17674          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17675            idummy,idummy)
17676          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
17677 ! Calculating the derivatives of Constraint energy with respect to Q
17678          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
17679            qinfrag(i,iset))
17680 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
17681 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
17682 !         hmnum=(hm2-hm1)/delta
17683 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
17684 !     &   qinfrag(i,iset))
17685 !         write(iout,*) "harmonicnum frag", hmnum
17686 ! Calculating the derivatives of Q with respect to cartesian coordinates
17687          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17688           idummy,idummy)
17689 !         write(iout,*) "dqwol "
17690 !         do ii=1,nres
17691 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17692 !         enddo
17693 !         write(iout,*) "dxqwol "
17694 !         do ii=1,nres
17695 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17696 !         enddo
17697 ! Calculating numerical gradients of dU/dQi and dQi/dxi
17698 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
17699 !     &  ,idummy,idummy)
17700 !  The gradients of Uconst in Cs
17701          do ii=0,nres
17702             do j=1,3
17703                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
17704                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
17705             enddo
17706          enddo
17707       enddo
17708       do i=1,npair
17709          kstart=ifrag(1,ipair(1,i,iset),iset)
17710          kend=ifrag(2,ipair(1,i,iset),iset)
17711          lstart=ifrag(1,ipair(2,i,iset),iset)
17712          lend=ifrag(2,ipair(2,i,iset),iset)
17713          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
17714          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
17715 !  Calculating dU/dQ
17716          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
17717 !         hm1=harmonic(qpair(i),qinpair(i,iset))
17718 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
17719 !         hmnum=(hm2-hm1)/delta
17720 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
17721 !     &   qinpair(i,iset))
17722 !         write(iout,*) "harmonicnum pair ", hmnum
17723 ! Calculating dQ/dXi
17724          call qwolynes_prim(kstart,kend,.false.,&
17725           lstart,lend)
17726 !         write(iout,*) "dqwol "
17727 !         do ii=1,nres
17728 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17729 !         enddo
17730 !         write(iout,*) "dxqwol "
17731 !         do ii=1,nres
17732 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17733 !        enddo
17734 ! Calculating numerical gradients
17735 !        call qwol_num(kstart,kend,.false.
17736 !     &  ,lstart,lend)
17737 ! The gradients of Uconst in Cs
17738          do ii=0,nres
17739             do j=1,3
17740                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
17741                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
17742             enddo
17743          enddo
17744       enddo
17745 !      write(iout,*) "Uconst inside subroutine ", Uconst
17746 ! Transforming the gradients from Cs to dCs for the backbone
17747       do i=0,nres
17748          do j=i+1,nres
17749            do k=1,3
17750              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
17751            enddo
17752          enddo
17753       enddo
17754 !  Transforming the gradients from Cs to dCs for the side chains
17755       do i=1,nres
17756          do j=1,3
17757            dudxconst(j,i)=duxconst(j,i)
17758          enddo
17759       enddo
17760 !      write(iout,*) "dU/ddc backbone "
17761 !       do ii=0,nres
17762 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
17763 !      enddo
17764 !      write(iout,*) "dU/ddX side chain "
17765 !      do ii=1,nres
17766 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
17767 !      enddo
17768 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
17769 !      call dEconstrQ_num
17770       return
17771       end subroutine EconstrQ
17772 !-----------------------------------------------------------------------------
17773       subroutine dEconstrQ_num
17774 ! Calculating numerical dUconst/ddc and dUconst/ddx
17775 !      implicit real*8 (a-h,o-z)
17776 !      include 'DIMENSIONS'
17777 !      include 'COMMON.CONTROL'
17778 !      include 'COMMON.VAR'
17779 !      include 'COMMON.MD'
17780       use MD_data
17781 !#ifndef LANG0
17782 !      include 'COMMON.LANGEVIN'
17783 !#else
17784 !      include 'COMMON.LANGEVIN.lang0'
17785 !#endif
17786 !      include 'COMMON.CHAIN'
17787 !      include 'COMMON.DERIV'
17788 !      include 'COMMON.GEO'
17789 !      include 'COMMON.LOCAL'
17790 !      include 'COMMON.INTERACT'
17791 !      include 'COMMON.IOUNITS'
17792 !      include 'COMMON.NAMES'
17793 !      include 'COMMON.TIME1'
17794       real(kind=8) :: uzap1,uzap2
17795       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17796       integer :: kstart,kend,lstart,lend,idummy
17797       real(kind=8) :: delta=1.0d-7
17798 !el local variables
17799       integer :: i,ii,j
17800 !     real(kind=8) ::
17801 !     For the backbone
17802       do i=0,nres-1
17803          do j=1,3
17804             dUcartan(j,i)=0.0d0
17805             cdummy(j,i)=dc(j,i)
17806             dc(j,i)=dc(j,i)+delta
17807             call chainbuild_cart
17808           uzap2=0.0d0
17809             do ii=1,nfrag
17810              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17811                 idummy,idummy)
17812                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17813                 qinfrag(ii,iset))
17814             enddo
17815             do ii=1,npair
17816                kstart=ifrag(1,ipair(1,ii,iset),iset)
17817                kend=ifrag(2,ipair(1,ii,iset),iset)
17818                lstart=ifrag(1,ipair(2,ii,iset),iset)
17819                lend=ifrag(2,ipair(2,ii,iset),iset)
17820                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17821                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17822                  qinpair(ii,iset))
17823             enddo
17824             dc(j,i)=cdummy(j,i)
17825             call chainbuild_cart
17826             uzap1=0.0d0
17827              do ii=1,nfrag
17828              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17829                 idummy,idummy)
17830                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17831                 qinfrag(ii,iset))
17832             enddo
17833             do ii=1,npair
17834                kstart=ifrag(1,ipair(1,ii,iset),iset)
17835                kend=ifrag(2,ipair(1,ii,iset),iset)
17836                lstart=ifrag(1,ipair(2,ii,iset),iset)
17837                lend=ifrag(2,ipair(2,ii,iset),iset)
17838                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17839                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17840                 qinpair(ii,iset))
17841             enddo
17842             ducartan(j,i)=(uzap2-uzap1)/(delta)
17843          enddo
17844       enddo
17845 ! Calculating numerical gradients for dU/ddx
17846       do i=0,nres-1
17847          duxcartan(j,i)=0.0d0
17848          do j=1,3
17849             cdummy(j,i)=dc(j,i+nres)
17850             dc(j,i+nres)=dc(j,i+nres)+delta
17851             call chainbuild_cart
17852           uzap2=0.0d0
17853             do ii=1,nfrag
17854              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17855                 idummy,idummy)
17856                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17857                 qinfrag(ii,iset))
17858             enddo
17859             do ii=1,npair
17860                kstart=ifrag(1,ipair(1,ii,iset),iset)
17861                kend=ifrag(2,ipair(1,ii,iset),iset)
17862                lstart=ifrag(1,ipair(2,ii,iset),iset)
17863                lend=ifrag(2,ipair(2,ii,iset),iset)
17864                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17865                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17866                 qinpair(ii,iset))
17867             enddo
17868             dc(j,i+nres)=cdummy(j,i)
17869             call chainbuild_cart
17870             uzap1=0.0d0
17871              do ii=1,nfrag
17872                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17873                 ifrag(2,ii,iset),.true.,idummy,idummy)
17874                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17875                 qinfrag(ii,iset))
17876             enddo
17877             do ii=1,npair
17878                kstart=ifrag(1,ipair(1,ii,iset),iset)
17879                kend=ifrag(2,ipair(1,ii,iset),iset)
17880                lstart=ifrag(1,ipair(2,ii,iset),iset)
17881                lend=ifrag(2,ipair(2,ii,iset),iset)
17882                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17883                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17884                 qinpair(ii,iset))
17885             enddo
17886             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17887          enddo
17888       enddo
17889       write(iout,*) "Numerical dUconst/ddc backbone "
17890       do ii=0,nres
17891         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17892       enddo
17893 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17894 !      do ii=1,nres
17895 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17896 !      enddo
17897       return
17898       end subroutine dEconstrQ_num
17899 !-----------------------------------------------------------------------------
17900 ! ssMD.F
17901 !-----------------------------------------------------------------------------
17902       subroutine check_energies
17903
17904 !      use random, only: ran_number
17905
17906 !      implicit none
17907 !     Includes
17908 !      include 'DIMENSIONS'
17909 !      include 'COMMON.CHAIN'
17910 !      include 'COMMON.VAR'
17911 !      include 'COMMON.IOUNITS'
17912 !      include 'COMMON.SBRIDGE'
17913 !      include 'COMMON.LOCAL'
17914 !      include 'COMMON.GEO'
17915
17916 !     External functions
17917 !EL      double precision ran_number
17918 !EL      external ran_number
17919
17920 !     Local variables
17921       integer :: i,j,k,l,lmax,p,pmax
17922       real(kind=8) :: rmin,rmax
17923       real(kind=8) :: eij
17924
17925       real(kind=8) :: d
17926       real(kind=8) :: wi,rij,tj,pj
17927 !      return
17928
17929       i=5
17930       j=14
17931
17932       d=dsc(1)
17933       rmin=2.0D0
17934       rmax=12.0D0
17935
17936       lmax=10000
17937       pmax=1
17938
17939       do k=1,3
17940         c(k,i)=0.0D0
17941         c(k,j)=0.0D0
17942         c(k,nres+i)=0.0D0
17943         c(k,nres+j)=0.0D0
17944       enddo
17945
17946       do l=1,lmax
17947
17948 !t        wi=ran_number(0.0D0,pi)
17949 !        wi=ran_number(0.0D0,pi/6.0D0)
17950 !        wi=0.0D0
17951 !t        tj=ran_number(0.0D0,pi)
17952 !t        pj=ran_number(0.0D0,pi)
17953 !        pj=ran_number(0.0D0,pi/6.0D0)
17954 !        pj=0.0D0
17955
17956         do p=1,pmax
17957 !t           rij=ran_number(rmin,rmax)
17958
17959            c(1,j)=d*sin(pj)*cos(tj)
17960            c(2,j)=d*sin(pj)*sin(tj)
17961            c(3,j)=d*cos(pj)
17962
17963            c(3,nres+i)=-rij
17964
17965            c(1,i)=d*sin(wi)
17966            c(3,i)=-rij-d*cos(wi)
17967
17968            do k=1,3
17969               dc(k,nres+i)=c(k,nres+i)-c(k,i)
17970               dc_norm(k,nres+i)=dc(k,nres+i)/d
17971               dc(k,nres+j)=c(k,nres+j)-c(k,j)
17972               dc_norm(k,nres+j)=dc(k,nres+j)/d
17973            enddo
17974
17975            call dyn_ssbond_ene(i,j,eij)
17976         enddo
17977       enddo
17978       call exit(1)
17979       return
17980       end subroutine check_energies
17981 !-----------------------------------------------------------------------------
17982       subroutine dyn_ssbond_ene(resi,resj,eij)
17983 !      implicit none
17984 !      Includes
17985       use calc_data
17986       use comm_sschecks
17987 !      include 'DIMENSIONS'
17988 !      include 'COMMON.SBRIDGE'
17989 !      include 'COMMON.CHAIN'
17990 !      include 'COMMON.DERIV'
17991 !      include 'COMMON.LOCAL'
17992 !      include 'COMMON.INTERACT'
17993 !      include 'COMMON.VAR'
17994 !      include 'COMMON.IOUNITS'
17995 !      include 'COMMON.CALC'
17996 #ifndef CLUST
17997 #ifndef WHAM
17998        use MD_data
17999 !      include 'COMMON.MD'
18000 !      use MD, only: totT,t_bath
18001 #endif
18002 #endif
18003 !     External functions
18004 !EL      double precision h_base
18005 !EL      external h_base
18006
18007 !     Input arguments
18008       integer :: resi,resj
18009
18010 !     Output arguments
18011       real(kind=8) :: eij
18012
18013 !     Local variables
18014       logical :: havebond
18015       integer itypi,itypj
18016       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
18017       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
18018       real(kind=8),dimension(3) :: dcosom1,dcosom2
18019       real(kind=8) :: ed
18020       real(kind=8) :: pom1,pom2
18021       real(kind=8) :: ljA,ljB,ljXs
18022       real(kind=8),dimension(1:3) :: d_ljB
18023       real(kind=8) :: ssA,ssB,ssC,ssXs
18024       real(kind=8) :: ssxm,ljxm,ssm,ljm
18025       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
18026       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
18027       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
18028 !-------FIRST METHOD
18029       real(kind=8) :: xm
18030       real(kind=8),dimension(1:3) :: d_xm
18031 !-------END FIRST METHOD
18032 !-------SECOND METHOD
18033 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
18034 !-------END SECOND METHOD
18035
18036 !-------TESTING CODE
18037 !el      logical :: checkstop,transgrad
18038 !el      common /sschecks/ checkstop,transgrad
18039
18040       integer :: icheck,nicheck,jcheck,njcheck
18041       real(kind=8),dimension(-1:1) :: echeck
18042       real(kind=8) :: deps,ssx0,ljx0
18043 !-------END TESTING CODE
18044
18045       eij=0.0d0
18046       i=resi
18047       j=resj
18048
18049 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
18050 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
18051
18052       itypi=itype(i,1)
18053       dxi=dc_norm(1,nres+i)
18054       dyi=dc_norm(2,nres+i)
18055       dzi=dc_norm(3,nres+i)
18056       dsci_inv=vbld_inv(i+nres)
18057
18058       itypj=itype(j,1)
18059       xj=c(1,nres+j)-c(1,nres+i)
18060       yj=c(2,nres+j)-c(2,nres+i)
18061       zj=c(3,nres+j)-c(3,nres+i)
18062       dxj=dc_norm(1,nres+j)
18063       dyj=dc_norm(2,nres+j)
18064       dzj=dc_norm(3,nres+j)
18065       dscj_inv=vbld_inv(j+nres)
18066
18067       chi1=chi(itypi,itypj)
18068       chi2=chi(itypj,itypi)
18069       chi12=chi1*chi2
18070       chip1=chip(itypi)
18071       chip2=chip(itypj)
18072       chip12=chip1*chip2
18073       alf1=alp(itypi)
18074       alf2=alp(itypj)
18075       alf12=0.5D0*(alf1+alf2)
18076
18077       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
18078       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18079 !     The following are set in sc_angular
18080 !      erij(1)=xj*rij
18081 !      erij(2)=yj*rij
18082 !      erij(3)=zj*rij
18083 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
18084 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
18085 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
18086       call sc_angular
18087       rij=1.0D0/rij  ! Reset this so it makes sense
18088
18089       sig0ij=sigma(itypi,itypj)
18090       sig=sig0ij*dsqrt(1.0D0/sigsq)
18091
18092       ljXs=sig-sig0ij
18093       ljA=eps1*eps2rt**2*eps3rt**2
18094       ljB=ljA*bb_aq(itypi,itypj)
18095       ljA=ljA*aa_aq(itypi,itypj)
18096       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
18097
18098       ssXs=d0cm
18099       deltat1=1.0d0-om1
18100       deltat2=1.0d0+om2
18101       deltat12=om2-om1+2.0d0
18102       cosphi=om12-om1*om2
18103       ssA=akcm
18104       ssB=akct*deltat12
18105       ssC=ss_depth &
18106            +akth*(deltat1*deltat1+deltat2*deltat2) &
18107            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
18108       ssxm=ssXs-0.5D0*ssB/ssA
18109
18110 !-------TESTING CODE
18111 !$$$c     Some extra output
18112 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
18113 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
18114 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
18115 !$$$      if (ssx0.gt.0.0d0) then
18116 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
18117 !$$$      else
18118 !$$$        ssx0=ssxm
18119 !$$$      endif
18120 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
18121 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
18122 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
18123 !$$$      return
18124 !-------END TESTING CODE
18125
18126 !-------TESTING CODE
18127 !     Stop and plot energy and derivative as a function of distance
18128       if (checkstop) then
18129         ssm=ssC-0.25D0*ssB*ssB/ssA
18130         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18131         if (ssm.lt.ljm .and. &
18132              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
18133           nicheck=1000
18134           njcheck=1
18135           deps=0.5d-7
18136         else
18137           checkstop=.false.
18138         endif
18139       endif
18140       if (.not.checkstop) then
18141         nicheck=0
18142         njcheck=-1
18143       endif
18144
18145       do icheck=0,nicheck
18146       do jcheck=-1,njcheck
18147       if (checkstop) rij=(ssxm-1.0d0)+ &
18148              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
18149 !-------END TESTING CODE
18150
18151       if (rij.gt.ljxm) then
18152         havebond=.false.
18153         ljd=rij-ljXs
18154         fac=(1.0D0/ljd)**expon
18155         e1=fac*fac*aa_aq(itypi,itypj)
18156         e2=fac*bb_aq(itypi,itypj)
18157         eij=eps1*eps2rt*eps3rt*(e1+e2)
18158         eps2der=eij*eps3rt
18159         eps3der=eij*eps2rt
18160         eij=eij*eps2rt*eps3rt
18161
18162         sigder=-sig/sigsq
18163         e1=e1*eps1*eps2rt**2*eps3rt**2
18164         ed=-expon*(e1+eij)/ljd
18165         sigder=ed*sigder
18166         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18167         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18168         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18169              -2.0D0*alf12*eps3der+sigder*sigsq_om12
18170       else if (rij.lt.ssxm) then
18171         havebond=.true.
18172         ssd=rij-ssXs
18173         eij=ssA*ssd*ssd+ssB*ssd+ssC
18174
18175         ed=2*akcm*ssd+akct*deltat12
18176         pom1=akct*ssd
18177         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18178         eom1=-2*akth*deltat1-pom1-om2*pom2
18179         eom2= 2*akth*deltat2+pom1-om1*pom2
18180         eom12=pom2
18181       else
18182         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18183
18184         d_ssxm(1)=0.5D0*akct/ssA
18185         d_ssxm(2)=-d_ssxm(1)
18186         d_ssxm(3)=0.0D0
18187
18188         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18189         d_ljxm(2)=d_ljxm(1)*sigsq_om2
18190         d_ljxm(3)=d_ljxm(1)*sigsq_om12
18191         d_ljxm(1)=d_ljxm(1)*sigsq_om1
18192
18193 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18194         xm=0.5d0*(ssxm+ljxm)
18195         do k=1,3
18196           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18197         enddo
18198         if (rij.lt.xm) then
18199           havebond=.true.
18200           ssm=ssC-0.25D0*ssB*ssB/ssA
18201           d_ssm(1)=0.5D0*akct*ssB/ssA
18202           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18203           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18204           d_ssm(3)=omega
18205           f1=(rij-xm)/(ssxm-xm)
18206           f2=(rij-ssxm)/(xm-ssxm)
18207           h1=h_base(f1,hd1)
18208           h2=h_base(f2,hd2)
18209           eij=ssm*h1+Ht*h2
18210           delta_inv=1.0d0/(xm-ssxm)
18211           deltasq_inv=delta_inv*delta_inv
18212           fac=ssm*hd1-Ht*hd2
18213           fac1=deltasq_inv*fac*(xm-rij)
18214           fac2=deltasq_inv*fac*(rij-ssxm)
18215           ed=delta_inv*(Ht*hd2-ssm*hd1)
18216           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18217           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18218           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18219         else
18220           havebond=.false.
18221           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18222           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18223           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18224           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18225                alf12/eps3rt)
18226           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18227           f1=(rij-ljxm)/(xm-ljxm)
18228           f2=(rij-xm)/(ljxm-xm)
18229           h1=h_base(f1,hd1)
18230           h2=h_base(f2,hd2)
18231           eij=Ht*h1+ljm*h2
18232           delta_inv=1.0d0/(ljxm-xm)
18233           deltasq_inv=delta_inv*delta_inv
18234           fac=Ht*hd1-ljm*hd2
18235           fac1=deltasq_inv*fac*(ljxm-rij)
18236           fac2=deltasq_inv*fac*(rij-xm)
18237           ed=delta_inv*(ljm*hd2-Ht*hd1)
18238           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18239           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18240           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18241         endif
18242 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18243
18244 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18245 !$$$        ssd=rij-ssXs
18246 !$$$        ljd=rij-ljXs
18247 !$$$        fac1=rij-ljxm
18248 !$$$        fac2=rij-ssxm
18249 !$$$
18250 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18251 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18252 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18253 !$$$
18254 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18255 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18256 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18257 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18258 !$$$        d_ssm(3)=omega
18259 !$$$
18260 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18261 !$$$        do k=1,3
18262 !$$$          d_ljm(k)=ljm*d_ljB(k)
18263 !$$$        enddo
18264 !$$$        ljm=ljm*ljB
18265 !$$$
18266 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18267 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18268 !$$$        d_ss(2)=akct*ssd
18269 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18270 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18271 !$$$        d_ss(3)=omega
18272 !$$$
18273 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18274 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18275 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18276 !$$$        do k=1,3
18277 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18278 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18279 !$$$        enddo
18280 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18281 !$$$
18282 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18283 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18284 !$$$        h1=h_base(f1,hd1)
18285 !$$$        h2=h_base(f2,hd2)
18286 !$$$        eij=ss*h1+ljf*h2
18287 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18288 !$$$        deltasq_inv=delta_inv*delta_inv
18289 !$$$        fac=ljf*hd2-ss*hd1
18290 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18291 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18292 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18293 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18294 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18295 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18296 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18297 !$$$
18298 !$$$        havebond=.false.
18299 !$$$        if (ed.gt.0.0d0) havebond=.true.
18300 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18301
18302       endif
18303
18304       if (havebond) then
18305 !#ifndef CLUST
18306 !#ifndef WHAM
18307 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18308 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18309 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18310 !        endif
18311 !#endif
18312 !#endif
18313         dyn_ssbond_ij(i,j)=eij
18314       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18315         dyn_ssbond_ij(i,j)=1.0d300
18316 !#ifndef CLUST
18317 !#ifndef WHAM
18318 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18319 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18320 !#endif
18321 !#endif
18322       endif
18323
18324 !-------TESTING CODE
18325 !el      if (checkstop) then
18326         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18327              "CHECKSTOP",rij,eij,ed
18328         echeck(jcheck)=eij
18329 !el      endif
18330       enddo
18331       if (checkstop) then
18332         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18333       endif
18334       enddo
18335       if (checkstop) then
18336         transgrad=.true.
18337         checkstop=.false.
18338       endif
18339 !-------END TESTING CODE
18340
18341       do k=1,3
18342         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18343         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18344       enddo
18345       do k=1,3
18346         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18347       enddo
18348       do k=1,3
18349         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18350              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18351              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18352         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18353              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18354              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18355       enddo
18356 !grad      do k=i,j-1
18357 !grad        do l=1,3
18358 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18359 !grad        enddo
18360 !grad      enddo
18361
18362       do l=1,3
18363         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18364         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18365       enddo
18366
18367       return
18368       end subroutine dyn_ssbond_ene
18369 !--------------------------------------------------------------------------
18370          subroutine triple_ssbond_ene(resi,resj,resk,eij)
18371 !      implicit none
18372 !      Includes
18373       use calc_data
18374       use comm_sschecks
18375 !      include 'DIMENSIONS'
18376 !      include 'COMMON.SBRIDGE'
18377 !      include 'COMMON.CHAIN'
18378 !      include 'COMMON.DERIV'
18379 !      include 'COMMON.LOCAL'
18380 !      include 'COMMON.INTERACT'
18381 !      include 'COMMON.VAR'
18382 !      include 'COMMON.IOUNITS'
18383 !      include 'COMMON.CALC'
18384 #ifndef CLUST
18385 #ifndef WHAM
18386        use MD_data
18387 !      include 'COMMON.MD'
18388 !      use MD, only: totT,t_bath
18389 #endif
18390 #endif
18391       double precision h_base
18392       external h_base
18393
18394 !c     Input arguments
18395       integer resi,resj,resk,m,itypi,itypj,itypk
18396
18397 !c     Output arguments
18398       double precision eij,eij1,eij2,eij3
18399
18400 !c     Local variables
18401       logical havebond
18402 !c      integer itypi,itypj,k,l
18403       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
18404       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
18405       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
18406       double precision sig0ij,ljd,sig,fac,e1,e2
18407       double precision dcosom1(3),dcosom2(3),ed
18408       double precision pom1,pom2
18409       double precision ljA,ljB,ljXs
18410       double precision d_ljB(1:3)
18411       double precision ssA,ssB,ssC,ssXs
18412       double precision ssxm,ljxm,ssm,ljm
18413       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
18414       eij=0.0
18415       if (dtriss.eq.0) return
18416       i=resi
18417       j=resj
18418       k=resk
18419 !C      write(iout,*) resi,resj,resk
18420       itypi=itype(i,1)
18421       dxi=dc_norm(1,nres+i)
18422       dyi=dc_norm(2,nres+i)
18423       dzi=dc_norm(3,nres+i)
18424       dsci_inv=vbld_inv(i+nres)
18425       xi=c(1,nres+i)
18426       yi=c(2,nres+i)
18427       zi=c(3,nres+i)
18428       itypj=itype(j,1)
18429       xj=c(1,nres+j)
18430       yj=c(2,nres+j)
18431       zj=c(3,nres+j)
18432
18433       dxj=dc_norm(1,nres+j)
18434       dyj=dc_norm(2,nres+j)
18435       dzj=dc_norm(3,nres+j)
18436       dscj_inv=vbld_inv(j+nres)
18437       itypk=itype(k,1)
18438       xk=c(1,nres+k)
18439       yk=c(2,nres+k)
18440       zk=c(3,nres+k)
18441
18442       dxk=dc_norm(1,nres+k)
18443       dyk=dc_norm(2,nres+k)
18444       dzk=dc_norm(3,nres+k)
18445       dscj_inv=vbld_inv(k+nres)
18446       xij=xj-xi
18447       xik=xk-xi
18448       xjk=xk-xj
18449       yij=yj-yi
18450       yik=yk-yi
18451       yjk=yk-yj
18452       zij=zj-zi
18453       zik=zk-zi
18454       zjk=zk-zj
18455       rrij=(xij*xij+yij*yij+zij*zij)
18456       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18457       rrik=(xik*xik+yik*yik+zik*zik)
18458       rik=dsqrt(rrik)
18459       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18460       rjk=dsqrt(rrjk)
18461 !C there are three combination of distances for each trisulfide bonds
18462 !C The first case the ith atom is the center
18463 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18464 !C distance y is second distance the a,b,c,d are parameters derived for
18465 !C this problem d parameter was set as a penalty currenlty set to 1.
18466       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18467       eij1=0.0d0
18468       else
18469       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18470       endif
18471 !C second case jth atom is center
18472       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18473       eij2=0.0d0
18474       else
18475       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18476       endif
18477 !C the third case kth atom is the center
18478       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18479       eij3=0.0d0
18480       else
18481       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18482       endif
18483 !C      eij2=0.0
18484 !C      eij3=0.0
18485 !C      eij1=0.0
18486       eij=eij1+eij2+eij3
18487 !C      write(iout,*)i,j,k,eij
18488 !C The energy penalty calculated now time for the gradient part
18489 !C derivative over rij
18490       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18491       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18492             gg(1)=xij*fac/rij
18493             gg(2)=yij*fac/rij
18494             gg(3)=zij*fac/rij
18495       do m=1,3
18496         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18497         gvdwx(m,j)=gvdwx(m,j)+gg(m)
18498       enddo
18499
18500       do l=1,3
18501         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18502         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18503       enddo
18504 !C now derivative over rik
18505       fac=-eij1**2/dtriss* &
18506       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18507       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18508             gg(1)=xik*fac/rik
18509             gg(2)=yik*fac/rik
18510             gg(3)=zik*fac/rik
18511       do m=1,3
18512         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18513         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18514       enddo
18515       do l=1,3
18516         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18517         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18518       enddo
18519 !C now derivative over rjk
18520       fac=-eij2**2/dtriss* &
18521       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18522       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18523             gg(1)=xjk*fac/rjk
18524             gg(2)=yjk*fac/rjk
18525             gg(3)=zjk*fac/rjk
18526       do m=1,3
18527         gvdwx(m,j)=gvdwx(m,j)-gg(m)
18528         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18529       enddo
18530       do l=1,3
18531         gvdwc(l,j)=gvdwc(l,j)-gg(l)
18532         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18533       enddo
18534       return
18535       end subroutine triple_ssbond_ene
18536
18537
18538
18539 !-----------------------------------------------------------------------------
18540       real(kind=8) function h_base(x,deriv)
18541 !     A smooth function going 0->1 in range [0,1]
18542 !     It should NOT be called outside range [0,1], it will not work there.
18543       implicit none
18544
18545 !     Input arguments
18546       real(kind=8) :: x
18547
18548 !     Output arguments
18549       real(kind=8) :: deriv
18550
18551 !     Local variables
18552       real(kind=8) :: xsq
18553
18554
18555 !     Two parabolas put together.  First derivative zero at extrema
18556 !$$$      if (x.lt.0.5D0) then
18557 !$$$        h_base=2.0D0*x*x
18558 !$$$        deriv=4.0D0*x
18559 !$$$      else
18560 !$$$        deriv=1.0D0-x
18561 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18562 !$$$        deriv=4.0D0*deriv
18563 !$$$      endif
18564
18565 !     Third degree polynomial.  First derivative zero at extrema
18566       h_base=x*x*(3.0d0-2.0d0*x)
18567       deriv=6.0d0*x*(1.0d0-x)
18568
18569 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18570 !$$$      xsq=x*x
18571 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18572 !$$$      deriv=x-1.0d0
18573 !$$$      deriv=deriv*deriv
18574 !$$$      deriv=30.0d0*xsq*deriv
18575
18576       return
18577       end function h_base
18578 !-----------------------------------------------------------------------------
18579       subroutine dyn_set_nss
18580 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18581 !      implicit none
18582       use MD_data, only: totT,t_bath
18583 !     Includes
18584 !      include 'DIMENSIONS'
18585 #ifdef MPI
18586       include "mpif.h"
18587 #endif
18588 !      include 'COMMON.SBRIDGE'
18589 !      include 'COMMON.CHAIN'
18590 !      include 'COMMON.IOUNITS'
18591 !      include 'COMMON.SETUP'
18592 !      include 'COMMON.MD'
18593 !     Local variables
18594       real(kind=8) :: emin
18595       integer :: i,j,imin,ierr
18596       integer :: diff,allnss,newnss
18597       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18598                 newihpb,newjhpb
18599       logical :: found
18600       integer,dimension(0:nfgtasks) :: i_newnss
18601       integer,dimension(0:nfgtasks) :: displ
18602       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18603       integer :: g_newnss
18604
18605       allnss=0
18606       do i=1,nres-1
18607         do j=i+1,nres
18608           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18609             allnss=allnss+1
18610             allflag(allnss)=0
18611             allihpb(allnss)=i
18612             alljhpb(allnss)=j
18613           endif
18614         enddo
18615       enddo
18616
18617 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18618
18619  1    emin=1.0d300
18620       do i=1,allnss
18621         if (allflag(i).eq.0 .and. &
18622              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18623           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18624           imin=i
18625         endif
18626       enddo
18627       if (emin.lt.1.0d300) then
18628         allflag(imin)=1
18629         do i=1,allnss
18630           if (allflag(i).eq.0 .and. &
18631                (allihpb(i).eq.allihpb(imin) .or. &
18632                alljhpb(i).eq.allihpb(imin) .or. &
18633                allihpb(i).eq.alljhpb(imin) .or. &
18634                alljhpb(i).eq.alljhpb(imin))) then
18635             allflag(i)=-1
18636           endif
18637         enddo
18638         goto 1
18639       endif
18640
18641 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18642
18643       newnss=0
18644       do i=1,allnss
18645         if (allflag(i).eq.1) then
18646           newnss=newnss+1
18647           newihpb(newnss)=allihpb(i)
18648           newjhpb(newnss)=alljhpb(i)
18649         endif
18650       enddo
18651
18652 #ifdef MPI
18653       if (nfgtasks.gt.1)then
18654
18655         call MPI_Reduce(newnss,g_newnss,1,&
18656           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
18657         call MPI_Gather(newnss,1,MPI_INTEGER,&
18658                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
18659         displ(0)=0
18660         do i=1,nfgtasks-1,1
18661           displ(i)=i_newnss(i-1)+displ(i-1)
18662         enddo
18663         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
18664                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
18665                          king,FG_COMM,IERR)
18666         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
18667                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
18668                          king,FG_COMM,IERR)
18669         if(fg_rank.eq.0) then
18670 !         print *,'g_newnss',g_newnss
18671 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
18672 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
18673          newnss=g_newnss
18674          do i=1,newnss
18675           newihpb(i)=g_newihpb(i)
18676           newjhpb(i)=g_newjhpb(i)
18677          enddo
18678         endif
18679       endif
18680 #endif
18681
18682       diff=newnss-nss
18683
18684 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
18685 !       print *,newnss,nss,maxdim
18686       do i=1,nss
18687         found=.false.
18688 !        print *,newnss
18689         do j=1,newnss
18690 !!          print *,j
18691           if (idssb(i).eq.newihpb(j) .and. &
18692                jdssb(i).eq.newjhpb(j)) found=.true.
18693         enddo
18694 #ifndef CLUST
18695 #ifndef WHAM
18696 !        write(iout,*) "found",found,i,j
18697         if (.not.found.and.fg_rank.eq.0) &
18698             write(iout,'(a15,f12.2,f8.1,2i5)') &
18699              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
18700 #endif
18701 #endif
18702       enddo
18703
18704       do i=1,newnss
18705         found=.false.
18706         do j=1,nss
18707 !          print *,i,j
18708           if (newihpb(i).eq.idssb(j) .and. &
18709                newjhpb(i).eq.jdssb(j)) found=.true.
18710         enddo
18711 #ifndef CLUST
18712 #ifndef WHAM
18713 !        write(iout,*) "found",found,i,j
18714         if (.not.found.and.fg_rank.eq.0) &
18715             write(iout,'(a15,f12.2,f8.1,2i5)') &
18716              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
18717 #endif
18718 #endif
18719       enddo
18720
18721       nss=newnss
18722       do i=1,nss
18723         idssb(i)=newihpb(i)
18724         jdssb(i)=newjhpb(i)
18725       enddo
18726
18727       return
18728       end subroutine dyn_set_nss
18729 ! Lipid transfer energy function
18730       subroutine Eliptransfer(eliptran)
18731 !C this is done by Adasko
18732 !C      print *,"wchodze"
18733 !C structure of box:
18734 !C      water
18735 !C--bordliptop-- buffore starts
18736 !C--bufliptop--- here true lipid starts
18737 !C      lipid
18738 !C--buflipbot--- lipid ends buffore starts
18739 !C--bordlipbot--buffore ends
18740       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
18741       integer :: i
18742       eliptran=0.0
18743 !      print *, "I am in eliptran"
18744       do i=ilip_start,ilip_end
18745 !C       do i=1,1
18746         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
18747          cycle
18748
18749         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
18750         if (positi.le.0.0) positi=positi+boxzsize
18751 !C        print *,i
18752 !C first for peptide groups
18753 !c for each residue check if it is in lipid or lipid water border area
18754        if ((positi.gt.bordlipbot)  &
18755       .and.(positi.lt.bordliptop)) then
18756 !C the energy transfer exist
18757         if (positi.lt.buflipbot) then
18758 !C what fraction I am in
18759          fracinbuf=1.0d0-      &
18760              ((positi-bordlipbot)/lipbufthick)
18761 !C lipbufthick is thickenes of lipid buffore
18762          sslip=sscalelip(fracinbuf)
18763          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18764          eliptran=eliptran+sslip*pepliptran
18765          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18766          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18767 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18768
18769 !C        print *,"doing sccale for lower part"
18770 !C         print *,i,sslip,fracinbuf,ssgradlip
18771         elseif (positi.gt.bufliptop) then
18772          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
18773          sslip=sscalelip(fracinbuf)
18774          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18775          eliptran=eliptran+sslip*pepliptran
18776          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18777          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18778 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18779 !C          print *, "doing sscalefor top part"
18780 !C         print *,i,sslip,fracinbuf,ssgradlip
18781         else
18782          eliptran=eliptran+pepliptran
18783 !C         print *,"I am in true lipid"
18784         endif
18785 !C       else
18786 !C       eliptran=elpitran+0.0 ! I am in water
18787        endif
18788        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
18789        enddo
18790 ! here starts the side chain transfer
18791        do i=ilip_start,ilip_end
18792         if (itype(i,1).eq.ntyp1) cycle
18793         positi=(mod(c(3,i+nres),boxzsize))
18794         if (positi.le.0) positi=positi+boxzsize
18795 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18796 !c for each residue check if it is in lipid or lipid water border area
18797 !C       respos=mod(c(3,i+nres),boxzsize)
18798 !C       print *,positi,bordlipbot,buflipbot
18799        if ((positi.gt.bordlipbot) &
18800        .and.(positi.lt.bordliptop)) then
18801 !C the energy transfer exist
18802         if (positi.lt.buflipbot) then
18803          fracinbuf=1.0d0-   &
18804            ((positi-bordlipbot)/lipbufthick)
18805 !C lipbufthick is thickenes of lipid buffore
18806          sslip=sscalelip(fracinbuf)
18807          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18808          eliptran=eliptran+sslip*liptranene(itype(i,1))
18809          gliptranx(3,i)=gliptranx(3,i) &
18810       +ssgradlip*liptranene(itype(i,1))
18811          gliptranc(3,i-1)= gliptranc(3,i-1) &
18812       +ssgradlip*liptranene(itype(i,1))
18813 !C         print *,"doing sccale for lower part"
18814         elseif (positi.gt.bufliptop) then
18815          fracinbuf=1.0d0-  &
18816       ((bordliptop-positi)/lipbufthick)
18817          sslip=sscalelip(fracinbuf)
18818          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18819          eliptran=eliptran+sslip*liptranene(itype(i,1))
18820          gliptranx(3,i)=gliptranx(3,i)  &
18821        +ssgradlip*liptranene(itype(i,1))
18822          gliptranc(3,i-1)= gliptranc(3,i-1) &
18823       +ssgradlip*liptranene(itype(i,1))
18824 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18825         else
18826          eliptran=eliptran+liptranene(itype(i,1))
18827 !C         print *,"I am in true lipid"
18828         endif
18829         endif ! if in lipid or buffor
18830 !C       else
18831 !C       eliptran=elpitran+0.0 ! I am in water
18832         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
18833        enddo
18834        return
18835        end  subroutine Eliptransfer
18836 !----------------------------------NANO FUNCTIONS
18837 !C-----------------------------------------------------------------------
18838 !C-----------------------------------------------------------
18839 !C This subroutine is to mimic the histone like structure but as well can be
18840 !C utilizet to nanostructures (infinit) small modification has to be used to
18841 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18842 !C gradient has to be modified at the ends
18843 !C The energy function is Kihara potential
18844 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18845 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18846 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18847 !C simple Kihara potential
18848       subroutine calctube(Etube)
18849       real(kind=8),dimension(3) :: vectube
18850       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18851        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
18852        sc_aa_tube,sc_bb_tube
18853       integer :: i,j,iti
18854       Etube=0.0d0
18855       do i=itube_start,itube_end
18856         enetube(i)=0.0d0
18857         enetube(i+nres)=0.0d0
18858       enddo
18859 !C first we calculate the distance from tube center
18860 !C for UNRES
18861        do i=itube_start,itube_end
18862 !C lets ommit dummy atoms for now
18863        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18864 !C now calculate distance from center of tube and direction vectors
18865       xmin=boxxsize
18866       ymin=boxysize
18867 ! Find minimum distance in periodic box
18868         do j=-1,1
18869          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18870          vectube(1)=vectube(1)+boxxsize*j
18871          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18872          vectube(2)=vectube(2)+boxysize*j
18873          xminact=abs(vectube(1)-tubecenter(1))
18874          yminact=abs(vectube(2)-tubecenter(2))
18875            if (xmin.gt.xminact) then
18876             xmin=xminact
18877             xtemp=vectube(1)
18878            endif
18879            if (ymin.gt.yminact) then
18880              ymin=yminact
18881              ytemp=vectube(2)
18882             endif
18883          enddo
18884       vectube(1)=xtemp
18885       vectube(2)=ytemp
18886       vectube(1)=vectube(1)-tubecenter(1)
18887       vectube(2)=vectube(2)-tubecenter(2)
18888
18889 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18890 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18891
18892 !C as the tube is infinity we do not calculate the Z-vector use of Z
18893 !C as chosen axis
18894       vectube(3)=0.0d0
18895 !C now calculte the distance
18896        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18897 !C now normalize vector
18898       vectube(1)=vectube(1)/tub_r
18899       vectube(2)=vectube(2)/tub_r
18900 !C calculte rdiffrence between r and r0
18901       rdiff=tub_r-tubeR0
18902 !C and its 6 power
18903       rdiff6=rdiff**6.0d0
18904 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18905        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18906 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18907 !C       print *,rdiff,rdiff6,pep_aa_tube
18908 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18909 !C now we calculate gradient
18910        fac=(-12.0d0*pep_aa_tube/rdiff6- &
18911             6.0d0*pep_bb_tube)/rdiff6/rdiff
18912 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18913 !C     &rdiff,fac
18914 !C now direction of gg_tube vector
18915         do j=1,3
18916         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18917         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18918         enddo
18919         enddo
18920 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18921 !C        print *,gg_tube(1,0),"TU"
18922
18923
18924        do i=itube_start,itube_end
18925 !C Lets not jump over memory as we use many times iti
18926          iti=itype(i,1)
18927 !C lets ommit dummy atoms for now
18928          if ((iti.eq.ntyp1)  &
18929 !C in UNRES uncomment the line below as GLY has no side-chain...
18930 !C      .or.(iti.eq.10)
18931         ) cycle
18932       xmin=boxxsize
18933       ymin=boxysize
18934         do j=-1,1
18935          vectube(1)=mod((c(1,i+nres)),boxxsize)
18936          vectube(1)=vectube(1)+boxxsize*j
18937          vectube(2)=mod((c(2,i+nres)),boxysize)
18938          vectube(2)=vectube(2)+boxysize*j
18939
18940          xminact=abs(vectube(1)-tubecenter(1))
18941          yminact=abs(vectube(2)-tubecenter(2))
18942            if (xmin.gt.xminact) then
18943             xmin=xminact
18944             xtemp=vectube(1)
18945            endif
18946            if (ymin.gt.yminact) then
18947              ymin=yminact
18948              ytemp=vectube(2)
18949             endif
18950          enddo
18951       vectube(1)=xtemp
18952       vectube(2)=ytemp
18953 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18954 !C     &     tubecenter(2)
18955       vectube(1)=vectube(1)-tubecenter(1)
18956       vectube(2)=vectube(2)-tubecenter(2)
18957
18958 !C as the tube is infinity we do not calculate the Z-vector use of Z
18959 !C as chosen axis
18960       vectube(3)=0.0d0
18961 !C now calculte the distance
18962        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18963 !C now normalize vector
18964       vectube(1)=vectube(1)/tub_r
18965       vectube(2)=vectube(2)/tub_r
18966
18967 !C calculte rdiffrence between r and r0
18968       rdiff=tub_r-tubeR0
18969 !C and its 6 power
18970       rdiff6=rdiff**6.0d0
18971 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18972        sc_aa_tube=sc_aa_tube_par(iti)
18973        sc_bb_tube=sc_bb_tube_par(iti)
18974        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18975        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
18976              6.0d0*sc_bb_tube/rdiff6/rdiff
18977 !C now direction of gg_tube vector
18978          do j=1,3
18979           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18980           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18981          enddo
18982         enddo
18983         do i=itube_start,itube_end
18984           Etube=Etube+enetube(i)+enetube(i+nres)
18985         enddo
18986 !C        print *,"ETUBE", etube
18987         return
18988         end subroutine calctube
18989 !C TO DO 1) add to total energy
18990 !C       2) add to gradient summation
18991 !C       3) add reading parameters (AND of course oppening of PARAM file)
18992 !C       4) add reading the center of tube
18993 !C       5) add COMMONs
18994 !C       6) add to zerograd
18995 !C       7) allocate matrices
18996
18997
18998 !C-----------------------------------------------------------------------
18999 !C-----------------------------------------------------------
19000 !C This subroutine is to mimic the histone like structure but as well can be
19001 !C utilizet to nanostructures (infinit) small modification has to be used to
19002 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19003 !C gradient has to be modified at the ends
19004 !C The energy function is Kihara potential
19005 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19006 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19007 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19008 !C simple Kihara potential
19009       subroutine calctube2(Etube)
19010             real(kind=8),dimension(3) :: vectube
19011       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19012        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
19013        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
19014       integer:: i,j,iti
19015       Etube=0.0d0
19016       do i=itube_start,itube_end
19017         enetube(i)=0.0d0
19018         enetube(i+nres)=0.0d0
19019       enddo
19020 !C first we calculate the distance from tube center
19021 !C first sugare-phosphate group for NARES this would be peptide group
19022 !C for UNRES
19023        do i=itube_start,itube_end
19024 !C lets ommit dummy atoms for now
19025
19026        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19027 !C now calculate distance from center of tube and direction vectors
19028 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19029 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19030 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19031 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19032       xmin=boxxsize
19033       ymin=boxysize
19034         do j=-1,1
19035          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19036          vectube(1)=vectube(1)+boxxsize*j
19037          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19038          vectube(2)=vectube(2)+boxysize*j
19039
19040          xminact=abs(vectube(1)-tubecenter(1))
19041          yminact=abs(vectube(2)-tubecenter(2))
19042            if (xmin.gt.xminact) then
19043             xmin=xminact
19044             xtemp=vectube(1)
19045            endif
19046            if (ymin.gt.yminact) then
19047              ymin=yminact
19048              ytemp=vectube(2)
19049             endif
19050          enddo
19051       vectube(1)=xtemp
19052       vectube(2)=ytemp
19053       vectube(1)=vectube(1)-tubecenter(1)
19054       vectube(2)=vectube(2)-tubecenter(2)
19055
19056 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19057 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19058
19059 !C as the tube is infinity we do not calculate the Z-vector use of Z
19060 !C as chosen axis
19061       vectube(3)=0.0d0
19062 !C now calculte the distance
19063        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19064 !C now normalize vector
19065       vectube(1)=vectube(1)/tub_r
19066       vectube(2)=vectube(2)/tub_r
19067 !C calculte rdiffrence between r and r0
19068       rdiff=tub_r-tubeR0
19069 !C and its 6 power
19070       rdiff6=rdiff**6.0d0
19071 !C THIS FRAGMENT MAKES TUBE FINITE
19072         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19073         if (positi.le.0) positi=positi+boxzsize
19074 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19075 !c for each residue check if it is in lipid or lipid water border area
19076 !C       respos=mod(c(3,i+nres),boxzsize)
19077 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19078        if ((positi.gt.bordtubebot)  &
19079         .and.(positi.lt.bordtubetop)) then
19080 !C the energy transfer exist
19081         if (positi.lt.buftubebot) then
19082          fracinbuf=1.0d0-  &
19083            ((positi-bordtubebot)/tubebufthick)
19084 !C lipbufthick is thickenes of lipid buffore
19085          sstube=sscalelip(fracinbuf)
19086          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19087 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19088          enetube(i)=enetube(i)+sstube*tubetranenepep
19089 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19090 !C     &+ssgradtube*tubetranene(itype(i,1))
19091 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19092 !C     &+ssgradtube*tubetranene(itype(i,1))
19093 !C         print *,"doing sccale for lower part"
19094         elseif (positi.gt.buftubetop) then
19095          fracinbuf=1.0d0-  &
19096         ((bordtubetop-positi)/tubebufthick)
19097          sstube=sscalelip(fracinbuf)
19098          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19099          enetube(i)=enetube(i)+sstube*tubetranenepep
19100 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19101 !C     &+ssgradtube*tubetranene(itype(i,1))
19102 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19103 !C     &+ssgradtube*tubetranene(itype(i,1))
19104 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19105         else
19106          sstube=1.0d0
19107          ssgradtube=0.0d0
19108          enetube(i)=enetube(i)+sstube*tubetranenepep
19109 !C         print *,"I am in true lipid"
19110         endif
19111         else
19112 !C          sstube=0.0d0
19113 !C          ssgradtube=0.0d0
19114         cycle
19115         endif ! if in lipid or buffor
19116
19117 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19118        enetube(i)=enetube(i)+sstube* &
19119         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
19120 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19121 !C       print *,rdiff,rdiff6,pep_aa_tube
19122 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19123 !C now we calculate gradient
19124        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
19125              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
19126 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19127 !C     &rdiff,fac
19128
19129 !C now direction of gg_tube vector
19130        do j=1,3
19131         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19132         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19133         enddo
19134          gg_tube(3,i)=gg_tube(3,i)  &
19135        +ssgradtube*enetube(i)/sstube/2.0d0
19136          gg_tube(3,i-1)= gg_tube(3,i-1)  &
19137        +ssgradtube*enetube(i)/sstube/2.0d0
19138
19139         enddo
19140 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19141 !C        print *,gg_tube(1,0),"TU"
19142         do i=itube_start,itube_end
19143 !C Lets not jump over memory as we use many times iti
19144          iti=itype(i,1)
19145 !C lets ommit dummy atoms for now
19146          if ((iti.eq.ntyp1) &
19147 !!C in UNRES uncomment the line below as GLY has no side-chain...
19148            .or.(iti.eq.10) &
19149           ) cycle
19150           vectube(1)=c(1,i+nres)
19151           vectube(1)=mod(vectube(1),boxxsize)
19152           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19153           vectube(2)=c(2,i+nres)
19154           vectube(2)=mod(vectube(2),boxysize)
19155           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19156
19157       vectube(1)=vectube(1)-tubecenter(1)
19158       vectube(2)=vectube(2)-tubecenter(2)
19159 !C THIS FRAGMENT MAKES TUBE FINITE
19160         positi=(mod(c(3,i+nres),boxzsize))
19161         if (positi.le.0) positi=positi+boxzsize
19162 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19163 !c for each residue check if it is in lipid or lipid water border area
19164 !C       respos=mod(c(3,i+nres),boxzsize)
19165 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19166
19167        if ((positi.gt.bordtubebot)  &
19168         .and.(positi.lt.bordtubetop)) then
19169 !C the energy transfer exist
19170         if (positi.lt.buftubebot) then
19171          fracinbuf=1.0d0- &
19172             ((positi-bordtubebot)/tubebufthick)
19173 !C lipbufthick is thickenes of lipid buffore
19174          sstube=sscalelip(fracinbuf)
19175          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19176 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19177          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19178 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19179 !C     &+ssgradtube*tubetranene(itype(i,1))
19180 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19181 !C     &+ssgradtube*tubetranene(itype(i,1))
19182 !C         print *,"doing sccale for lower part"
19183         elseif (positi.gt.buftubetop) then
19184          fracinbuf=1.0d0- &
19185         ((bordtubetop-positi)/tubebufthick)
19186
19187          sstube=sscalelip(fracinbuf)
19188          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19189          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19190 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19191 !C     &+ssgradtube*tubetranene(itype(i,1))
19192 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19193 !C     &+ssgradtube*tubetranene(itype(i,1))
19194 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19195         else
19196          sstube=1.0d0
19197          ssgradtube=0.0d0
19198          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19199 !C         print *,"I am in true lipid"
19200         endif
19201         else
19202 !C          sstube=0.0d0
19203 !C          ssgradtube=0.0d0
19204         cycle
19205         endif ! if in lipid or buffor
19206 !CEND OF FINITE FRAGMENT
19207 !C as the tube is infinity we do not calculate the Z-vector use of Z
19208 !C as chosen axis
19209       vectube(3)=0.0d0
19210 !C now calculte the distance
19211        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19212 !C now normalize vector
19213       vectube(1)=vectube(1)/tub_r
19214       vectube(2)=vectube(2)/tub_r
19215 !C calculte rdiffrence between r and r0
19216       rdiff=tub_r-tubeR0
19217 !C and its 6 power
19218       rdiff6=rdiff**6.0d0
19219 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19220        sc_aa_tube=sc_aa_tube_par(iti)
19221        sc_bb_tube=sc_bb_tube_par(iti)
19222        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19223                        *sstube+enetube(i+nres)
19224 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19225 !C now we calculate gradient
19226        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19227             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19228 !C now direction of gg_tube vector
19229          do j=1,3
19230           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19231           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19232          enddo
19233          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19234        +ssgradtube*enetube(i+nres)/sstube
19235          gg_tube(3,i-1)= gg_tube(3,i-1) &
19236        +ssgradtube*enetube(i+nres)/sstube
19237
19238         enddo
19239         do i=itube_start,itube_end
19240           Etube=Etube+enetube(i)+enetube(i+nres)
19241         enddo
19242 !C        print *,"ETUBE", etube
19243         return
19244         end subroutine calctube2
19245 !=====================================================================================================================================
19246       subroutine calcnano(Etube)
19247       real(kind=8),dimension(3) :: vectube
19248
19249       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19250        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19251        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19252        integer:: i,j,iti,r
19253
19254       Etube=0.0d0
19255 !      print *,itube_start,itube_end,"poczatek"
19256       do i=itube_start,itube_end
19257         enetube(i)=0.0d0
19258         enetube(i+nres)=0.0d0
19259       enddo
19260 !C first we calculate the distance from tube center
19261 !C first sugare-phosphate group for NARES this would be peptide group
19262 !C for UNRES
19263        do i=itube_start,itube_end
19264 !C lets ommit dummy atoms for now
19265        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19266 !C now calculate distance from center of tube and direction vectors
19267       xmin=boxxsize
19268       ymin=boxysize
19269       zmin=boxzsize
19270
19271         do j=-1,1
19272          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19273          vectube(1)=vectube(1)+boxxsize*j
19274          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19275          vectube(2)=vectube(2)+boxysize*j
19276          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19277          vectube(3)=vectube(3)+boxzsize*j
19278
19279
19280          xminact=dabs(vectube(1)-tubecenter(1))
19281          yminact=dabs(vectube(2)-tubecenter(2))
19282          zminact=dabs(vectube(3)-tubecenter(3))
19283
19284            if (xmin.gt.xminact) then
19285             xmin=xminact
19286             xtemp=vectube(1)
19287            endif
19288            if (ymin.gt.yminact) then
19289              ymin=yminact
19290              ytemp=vectube(2)
19291             endif
19292            if (zmin.gt.zminact) then
19293              zmin=zminact
19294              ztemp=vectube(3)
19295             endif
19296          enddo
19297       vectube(1)=xtemp
19298       vectube(2)=ytemp
19299       vectube(3)=ztemp
19300
19301       vectube(1)=vectube(1)-tubecenter(1)
19302       vectube(2)=vectube(2)-tubecenter(2)
19303       vectube(3)=vectube(3)-tubecenter(3)
19304
19305 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19306 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19307 !C as the tube is infinity we do not calculate the Z-vector use of Z
19308 !C as chosen axis
19309 !C      vectube(3)=0.0d0
19310 !C now calculte the distance
19311        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19312 !C now normalize vector
19313       vectube(1)=vectube(1)/tub_r
19314       vectube(2)=vectube(2)/tub_r
19315       vectube(3)=vectube(3)/tub_r
19316 !C calculte rdiffrence between r and r0
19317       rdiff=tub_r-tubeR0
19318 !C and its 6 power
19319       rdiff6=rdiff**6.0d0
19320 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19321        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19322 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19323 !C       print *,rdiff,rdiff6,pep_aa_tube
19324 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19325 !C now we calculate gradient
19326        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19327             6.0d0*pep_bb_tube)/rdiff6/rdiff
19328 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19329 !C     &rdiff,fac
19330          if (acavtubpep.eq.0.0d0) then
19331 !C go to 667
19332          enecavtube(i)=0.0
19333          faccav=0.0
19334          else
19335          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19336          enecavtube(i)=  &
19337         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19338         /denominator
19339          enecavtube(i)=0.0
19340          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19341         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19342         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19343         /denominator**2.0d0
19344 !C         faccav=0.0
19345 !C         fac=fac+faccav
19346 !C 667     continue
19347          endif
19348           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19349         do j=1,3
19350         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19351         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19352         enddo
19353         enddo
19354
19355        do i=itube_start,itube_end
19356         enecavtube(i)=0.0d0
19357 !C Lets not jump over memory as we use many times iti
19358          iti=itype(i,1)
19359 !C lets ommit dummy atoms for now
19360          if ((iti.eq.ntyp1) &
19361 !C in UNRES uncomment the line below as GLY has no side-chain...
19362 !C      .or.(iti.eq.10)
19363          ) cycle
19364       xmin=boxxsize
19365       ymin=boxysize
19366       zmin=boxzsize
19367         do j=-1,1
19368          vectube(1)=dmod((c(1,i+nres)),boxxsize)
19369          vectube(1)=vectube(1)+boxxsize*j
19370          vectube(2)=dmod((c(2,i+nres)),boxysize)
19371          vectube(2)=vectube(2)+boxysize*j
19372          vectube(3)=dmod((c(3,i+nres)),boxzsize)
19373          vectube(3)=vectube(3)+boxzsize*j
19374
19375
19376          xminact=dabs(vectube(1)-tubecenter(1))
19377          yminact=dabs(vectube(2)-tubecenter(2))
19378          zminact=dabs(vectube(3)-tubecenter(3))
19379
19380            if (xmin.gt.xminact) then
19381             xmin=xminact
19382             xtemp=vectube(1)
19383            endif
19384            if (ymin.gt.yminact) then
19385              ymin=yminact
19386              ytemp=vectube(2)
19387             endif
19388            if (zmin.gt.zminact) then
19389              zmin=zminact
19390              ztemp=vectube(3)
19391             endif
19392          enddo
19393       vectube(1)=xtemp
19394       vectube(2)=ytemp
19395       vectube(3)=ztemp
19396
19397 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19398 !C     &     tubecenter(2)
19399       vectube(1)=vectube(1)-tubecenter(1)
19400       vectube(2)=vectube(2)-tubecenter(2)
19401       vectube(3)=vectube(3)-tubecenter(3)
19402 !C now calculte the distance
19403        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19404 !C now normalize vector
19405       vectube(1)=vectube(1)/tub_r
19406       vectube(2)=vectube(2)/tub_r
19407       vectube(3)=vectube(3)/tub_r
19408
19409 !C calculte rdiffrence between r and r0
19410       rdiff=tub_r-tubeR0
19411 !C and its 6 power
19412       rdiff6=rdiff**6.0d0
19413        sc_aa_tube=sc_aa_tube_par(iti)
19414        sc_bb_tube=sc_bb_tube_par(iti)
19415        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19416 !C       enetube(i+nres)=0.0d0
19417 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19418 !C now we calculate gradient
19419        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
19420             6.0d0*sc_bb_tube/rdiff6/rdiff
19421 !C       fac=0.0
19422 !C now direction of gg_tube vector
19423 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
19424          if (acavtub(iti).eq.0.0d0) then
19425 !C go to 667
19426          enecavtube(i+nres)=0.0d0
19427          faccav=0.0d0
19428          else
19429          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
19430          enecavtube(i+nres)=   &
19431         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
19432         /denominator
19433 !C         enecavtube(i)=0.0
19434          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
19435         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
19436         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
19437         /denominator**2.0d0
19438 !C         faccav=0.0
19439          fac=fac+faccav
19440 !C 667     continue
19441          endif
19442 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
19443 !C     &   enecavtube(i),faccav
19444 !C         print *,"licz=",
19445 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
19446 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
19447          do j=1,3
19448           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19449           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19450          enddo
19451           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
19452         enddo
19453
19454
19455
19456         do i=itube_start,itube_end
19457           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19458          +enecavtube(i+nres)
19459         enddo
19460 !        do i=1,20
19461 !         print *,"begin", i,"a"
19462 !         do r=1,10000
19463 !          rdiff=r/100.0d0
19464 !          rdiff6=rdiff**6.0d0
19465 !          sc_aa_tube=sc_aa_tube_par(i)
19466 !          sc_bb_tube=sc_bb_tube_par(i)
19467 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19468 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19469 !          enecavtube(i)=   &
19470 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19471 !         /denominator
19472
19473 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19474 !         enddo
19475 !         print *,"end",i,"a"
19476 !        enddo
19477 !C        print *,"ETUBE", etube
19478         return
19479         end subroutine calcnano
19480
19481 !===============================================
19482 !--------------------------------------------------------------------------------
19483 !C first for shielding is setting of function of side-chains
19484
19485        subroutine set_shield_fac2
19486        real(kind=8) :: div77_81=0.974996043d0, &
19487         div4_81=0.2222222222d0
19488        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19489          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19490          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19491          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19492 !C the vector between center of side_chain and peptide group
19493        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19494          pept_group,costhet_grad,cosphi_grad_long, &
19495          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19496          sh_frac_dist_grad,pep_side
19497         integer i,j,k
19498 !C      write(2,*) "ivec",ivec_start,ivec_end
19499       do i=1,nres
19500         fac_shield(i)=0.0d0
19501         ishield_list(i)=0
19502         do j=1,3
19503         grad_shield(j,i)=0.0d0
19504         enddo
19505       enddo
19506       do i=ivec_start,ivec_end
19507 !C      do i=1,nres-1
19508 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19509 !      ishield_list(i)=0
19510       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19511 !Cif there two consequtive dummy atoms there is no peptide group between them
19512 !C the line below has to be changed for FGPROC>1
19513       VolumeTotal=0.0
19514       do k=1,nres
19515        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19516        dist_pep_side=0.0
19517        dist_side_calf=0.0
19518        do j=1,3
19519 !C first lets set vector conecting the ithe side-chain with kth side-chain
19520       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19521 !C      pep_side(j)=2.0d0
19522 !C and vector conecting the side-chain with its proper calfa
19523       side_calf(j)=c(j,k+nres)-c(j,k)
19524 !C      side_calf(j)=2.0d0
19525       pept_group(j)=c(j,i)-c(j,i+1)
19526 !C lets have their lenght
19527       dist_pep_side=pep_side(j)**2+dist_pep_side
19528       dist_side_calf=dist_side_calf+side_calf(j)**2
19529       dist_pept_group=dist_pept_group+pept_group(j)**2
19530       enddo
19531        dist_pep_side=sqrt(dist_pep_side)
19532        dist_pept_group=sqrt(dist_pept_group)
19533        dist_side_calf=sqrt(dist_side_calf)
19534       do j=1,3
19535         pep_side_norm(j)=pep_side(j)/dist_pep_side
19536         side_calf_norm(j)=dist_side_calf
19537       enddo
19538 !C now sscale fraction
19539        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19540 !       print *,buff_shield,"buff",sh_frac_dist
19541 !C now sscale
19542         if (sh_frac_dist.le.0.0) cycle
19543 !C        print *,ishield_list(i),i
19544 !C If we reach here it means that this side chain reaches the shielding sphere
19545 !C Lets add him to the list for gradient
19546         ishield_list(i)=ishield_list(i)+1
19547 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19548 !C this list is essential otherwise problem would be O3
19549         shield_list(ishield_list(i),i)=k
19550 !C Lets have the sscale value
19551         if (sh_frac_dist.gt.1.0) then
19552          scale_fac_dist=1.0d0
19553          do j=1,3
19554          sh_frac_dist_grad(j)=0.0d0
19555          enddo
19556         else
19557          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19558                         *(2.0d0*sh_frac_dist-3.0d0)
19559          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19560                        /dist_pep_side/buff_shield*0.5d0
19561          do j=1,3
19562          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19563 !C         sh_frac_dist_grad(j)=0.0d0
19564 !C         scale_fac_dist=1.0d0
19565 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19566 !C     &                    sh_frac_dist_grad(j)
19567          enddo
19568         endif
19569 !C this is what is now we have the distance scaling now volume...
19570       short=short_r_sidechain(itype(k,1))
19571       long=long_r_sidechain(itype(k,1))
19572       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19573       sinthet=short/dist_pep_side*costhet
19574 !      print *,"SORT",short,long,sinthet,costhet
19575 !C now costhet_grad
19576 !C       costhet=0.6d0
19577 !C       sinthet=0.8
19578        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19579 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19580 !C     &             -short/dist_pep_side**2/costhet)
19581 !C       costhet_fac=0.0d0
19582        do j=1,3
19583          costhet_grad(j)=costhet_fac*pep_side(j)
19584        enddo
19585 !C remember for the final gradient multiply costhet_grad(j)
19586 !C for side_chain by factor -2 !
19587 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19588 !C pep_side0pept_group is vector multiplication
19589       pep_side0pept_group=0.0d0
19590       do j=1,3
19591       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19592       enddo
19593       cosalfa=(pep_side0pept_group/ &
19594       (dist_pep_side*dist_side_calf))
19595       fac_alfa_sin=1.0d0-cosalfa**2
19596       fac_alfa_sin=dsqrt(fac_alfa_sin)
19597       rkprim=fac_alfa_sin*(long-short)+short
19598 !C      rkprim=short
19599
19600 !C now costhet_grad
19601        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19602 !C       cosphi=0.6
19603        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19604        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19605            dist_pep_side**2)
19606 !C       sinphi=0.8
19607        do j=1,3
19608          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19609       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19610       *(long-short)/fac_alfa_sin*cosalfa/ &
19611       ((dist_pep_side*dist_side_calf))* &
19612       ((side_calf(j))-cosalfa* &
19613       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19614 !C       cosphi_grad_long(j)=0.0d0
19615         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19616       *(long-short)/fac_alfa_sin*cosalfa &
19617       /((dist_pep_side*dist_side_calf))* &
19618       (pep_side(j)- &
19619       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19620 !C       cosphi_grad_loc(j)=0.0d0
19621        enddo
19622 !C      print *,sinphi,sinthet
19623       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19624                          /VSolvSphere_div
19625 !C     &                    *wshield
19626 !C now the gradient...
19627       do j=1,3
19628       grad_shield(j,i)=grad_shield(j,i) &
19629 !C gradient po skalowaniu
19630                      +(sh_frac_dist_grad(j)*VofOverlap &
19631 !C  gradient po costhet
19632             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19633         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19634             sinphi/sinthet*costhet*costhet_grad(j) &
19635            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19636         )*wshield
19637 !C grad_shield_side is Cbeta sidechain gradient
19638       grad_shield_side(j,ishield_list(i),i)=&
19639              (sh_frac_dist_grad(j)*-2.0d0&
19640              *VofOverlap&
19641             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19642        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19643             sinphi/sinthet*costhet*costhet_grad(j)&
19644            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19645             )*wshield
19646 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
19647 !            sinphi/sinthet,&
19648 !           +sinthet/sinphi,"HERE"
19649        grad_shield_loc(j,ishield_list(i),i)=   &
19650             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19651       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
19652             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
19653              ))&
19654              *wshield
19655 !         print *,grad_shield_loc(j,ishield_list(i),i)
19656       enddo
19657       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
19658       enddo
19659       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
19660
19661 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
19662       enddo
19663       return
19664       end subroutine set_shield_fac2
19665 !----------------------------------------------------------------------------
19666 ! SOUBROUTINE FOR AFM
19667        subroutine AFMvel(Eafmforce)
19668        use MD_data, only:totTafm
19669       real(kind=8),dimension(3) :: diffafm
19670       real(kind=8) :: afmdist,Eafmforce
19671        integer :: i
19672 !C Only for check grad COMMENT if not used for checkgrad
19673 !C      totT=3.0d0
19674 !C--------------------------------------------------------
19675 !C      print *,"wchodze"
19676       afmdist=0.0d0
19677       Eafmforce=0.0d0
19678       do i=1,3
19679       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19680       afmdist=afmdist+diffafm(i)**2
19681       enddo
19682       afmdist=dsqrt(afmdist)
19683 !      totTafm=3.0
19684       Eafmforce=0.5d0*forceAFMconst &
19685       *(distafminit+totTafm*velAFMconst-afmdist)**2
19686 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
19687       do i=1,3
19688       gradafm(i,afmend-1)=-forceAFMconst* &
19689        (distafminit+totTafm*velAFMconst-afmdist) &
19690        *diffafm(i)/afmdist
19691       gradafm(i,afmbeg-1)=forceAFMconst* &
19692       (distafminit+totTafm*velAFMconst-afmdist) &
19693       *diffafm(i)/afmdist
19694       enddo
19695 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
19696       return
19697       end subroutine AFMvel
19698 !---------------------------------------------------------
19699        subroutine AFMforce(Eafmforce)
19700
19701       real(kind=8),dimension(3) :: diffafm
19702 !      real(kind=8) ::afmdist
19703       real(kind=8) :: afmdist,Eafmforce
19704       integer :: i
19705       afmdist=0.0d0
19706       Eafmforce=0.0d0
19707       do i=1,3
19708       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19709       afmdist=afmdist+diffafm(i)**2
19710       enddo
19711       afmdist=dsqrt(afmdist)
19712 !      print *,afmdist,distafminit
19713       Eafmforce=-forceAFMconst*(afmdist-distafminit)
19714       do i=1,3
19715       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
19716       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
19717       enddo
19718 !C      print *,'AFM',Eafmforce
19719       return
19720       end subroutine AFMforce
19721
19722 !-----------------------------------------------------------------------------
19723 #ifdef WHAM
19724       subroutine read_ssHist
19725 !      implicit none
19726 !      Includes
19727 !      include 'DIMENSIONS'
19728 !      include "DIMENSIONS.FREE"
19729 !      include 'COMMON.FREE'
19730 !     Local variables
19731       integer :: i,j
19732       character(len=80) :: controlcard
19733
19734       do i=1,dyn_nssHist
19735         call card_concat(controlcard,.true.)
19736         read(controlcard,*) &
19737              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
19738       enddo
19739
19740       return
19741       end subroutine read_ssHist
19742 #endif
19743 !-----------------------------------------------------------------------------
19744       integer function indmat(i,j)
19745 !el
19746 ! get the position of the jth ijth fragment of the chain coordinate system
19747 ! in the fromto array.
19748         integer :: i,j
19749
19750         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
19751       return
19752       end function indmat
19753 !-----------------------------------------------------------------------------
19754       real(kind=8) function sigm(x)
19755 !el
19756        real(kind=8) :: x
19757         sigm=0.25d0*x
19758       return
19759       end function sigm
19760 !-----------------------------------------------------------------------------
19761 !-----------------------------------------------------------------------------
19762       subroutine alloc_ener_arrays
19763 !EL Allocation of arrays used by module energy
19764       use MD_data, only: mset
19765 !el local variables
19766       integer :: i,j
19767
19768       if(nres.lt.100) then
19769         maxconts=nres
19770       elseif(nres.lt.200) then
19771         maxconts=0.8*nres      ! Max. number of contacts per residue
19772       else
19773         maxconts=0.6*nres ! (maxconts=maxres/4)
19774       endif
19775       maxcont=12*nres      ! Max. number of SC contacts
19776       maxvar=6*nres      ! Max. number of variables
19777 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19778       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19779 !----------------------
19780 ! arrays in subroutine init_int_table
19781 !el#ifdef MPI
19782 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
19783 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
19784 !el#endif
19785       allocate(nint_gr(nres))
19786       allocate(nscp_gr(nres))
19787       allocate(ielstart(nres))
19788       allocate(ielend(nres))
19789 !(maxres)
19790       allocate(istart(nres,maxint_gr))
19791       allocate(iend(nres,maxint_gr))
19792 !(maxres,maxint_gr)
19793       allocate(iscpstart(nres,maxint_gr))
19794       allocate(iscpend(nres,maxint_gr))
19795 !(maxres,maxint_gr)
19796       allocate(ielstart_vdw(nres))
19797       allocate(ielend_vdw(nres))
19798 !(maxres)
19799       allocate(nint_gr_nucl(nres))
19800       allocate(nscp_gr_nucl(nres))
19801       allocate(ielstart_nucl(nres))
19802       allocate(ielend_nucl(nres))
19803 !(maxres)
19804       allocate(istart_nucl(nres,maxint_gr))
19805       allocate(iend_nucl(nres,maxint_gr))
19806 !(maxres,maxint_gr)
19807       allocate(iscpstart_nucl(nres,maxint_gr))
19808       allocate(iscpend_nucl(nres,maxint_gr))
19809 !(maxres,maxint_gr)
19810       allocate(ielstart_vdw_nucl(nres))
19811       allocate(ielend_vdw_nucl(nres))
19812
19813       allocate(lentyp(0:nfgtasks-1))
19814 !(0:maxprocs-1)
19815 !----------------------
19816 ! commom.contacts
19817 !      common /contacts/
19818       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
19819       allocate(icont(2,maxcont))
19820 !(2,maxcont)
19821 !      common /contacts1/
19822       allocate(num_cont(0:nres+4))
19823 !(maxres)
19824       allocate(jcont(maxconts,nres))
19825 !(maxconts,maxres)
19826       allocate(facont(maxconts,nres))
19827 !(maxconts,maxres)
19828       allocate(gacont(3,maxconts,nres))
19829 !(3,maxconts,maxres)
19830 !      common /contacts_hb/
19831       allocate(gacontp_hb1(3,maxconts,nres))
19832       allocate(gacontp_hb2(3,maxconts,nres))
19833       allocate(gacontp_hb3(3,maxconts,nres))
19834       allocate(gacontm_hb1(3,maxconts,nres))
19835       allocate(gacontm_hb2(3,maxconts,nres))
19836       allocate(gacontm_hb3(3,maxconts,nres))
19837       allocate(gacont_hbr(3,maxconts,nres))
19838       allocate(grij_hb_cont(3,maxconts,nres))
19839 !(3,maxconts,maxres)
19840       allocate(facont_hb(maxconts,nres))
19841
19842       allocate(ees0p(maxconts,nres))
19843       allocate(ees0m(maxconts,nres))
19844       allocate(d_cont(maxconts,nres))
19845       allocate(ees0plist(maxconts,nres))
19846
19847 !(maxconts,maxres)
19848       allocate(num_cont_hb(nres))
19849 !(maxres)
19850       allocate(jcont_hb(maxconts,nres))
19851 !(maxconts,maxres)
19852 !      common /rotat/
19853       allocate(Ug(2,2,nres))
19854       allocate(Ugder(2,2,nres))
19855       allocate(Ug2(2,2,nres))
19856       allocate(Ug2der(2,2,nres))
19857 !(2,2,maxres)
19858       allocate(obrot(2,nres))
19859       allocate(obrot2(2,nres))
19860       allocate(obrot_der(2,nres))
19861       allocate(obrot2_der(2,nres))
19862 !(2,maxres)
19863 !      common /precomp1/
19864       allocate(mu(2,nres))
19865       allocate(muder(2,nres))
19866       allocate(Ub2(2,nres))
19867       Ub2(1,:)=0.0d0
19868       Ub2(2,:)=0.0d0
19869       allocate(Ub2der(2,nres))
19870       allocate(Ctobr(2,nres))
19871       allocate(Ctobrder(2,nres))
19872       allocate(Dtobr2(2,nres))
19873       allocate(Dtobr2der(2,nres))
19874 !(2,maxres)
19875       allocate(EUg(2,2,nres))
19876       allocate(EUgder(2,2,nres))
19877       allocate(CUg(2,2,nres))
19878       allocate(CUgder(2,2,nres))
19879       allocate(DUg(2,2,nres))
19880       allocate(Dugder(2,2,nres))
19881       allocate(DtUg2(2,2,nres))
19882       allocate(DtUg2der(2,2,nres))
19883 !(2,2,maxres)
19884 !      common /precomp2/
19885       allocate(Ug2Db1t(2,nres))
19886       allocate(Ug2Db1tder(2,nres))
19887       allocate(CUgb2(2,nres))
19888       allocate(CUgb2der(2,nres))
19889 !(2,maxres)
19890       allocate(EUgC(2,2,nres))
19891       allocate(EUgCder(2,2,nres))
19892       allocate(EUgD(2,2,nres))
19893       allocate(EUgDder(2,2,nres))
19894       allocate(DtUg2EUg(2,2,nres))
19895       allocate(Ug2DtEUg(2,2,nres))
19896 !(2,2,maxres)
19897       allocate(Ug2DtEUgder(2,2,2,nres))
19898       allocate(DtUg2EUgder(2,2,2,nres))
19899 !(2,2,2,maxres)
19900 !      common /rotat_old/
19901       allocate(costab(nres))
19902       allocate(sintab(nres))
19903       allocate(costab2(nres))
19904       allocate(sintab2(nres))
19905 !(maxres)
19906 !      common /dipmat/
19907       allocate(a_chuj(2,2,maxconts,nres))
19908 !(2,2,maxconts,maxres)(maxconts=maxres/4)
19909       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
19910 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
19911 !      common /contdistrib/
19912       allocate(ncont_sent(nres))
19913       allocate(ncont_recv(nres))
19914
19915       allocate(iat_sent(nres))
19916 !(maxres)
19917       allocate(iint_sent(4,nres,nres))
19918       allocate(iint_sent_local(4,nres,nres))
19919 !(4,maxres,maxres)
19920       allocate(iturn3_sent(4,0:nres+4))
19921       allocate(iturn4_sent(4,0:nres+4))
19922       allocate(iturn3_sent_local(4,nres))
19923       allocate(iturn4_sent_local(4,nres))
19924 !(4,maxres)
19925       allocate(itask_cont_from(0:nfgtasks-1))
19926       allocate(itask_cont_to(0:nfgtasks-1))
19927 !(0:max_fg_procs-1)
19928
19929
19930
19931 !----------------------
19932 ! commom.deriv;
19933 !      common /derivat/
19934       allocate(dcdv(6,maxdim))
19935       allocate(dxdv(6,maxdim))
19936 !(6,maxdim)
19937       allocate(dxds(6,nres))
19938 !(6,maxres)
19939       allocate(gradx(3,-1:nres,0:2))
19940       allocate(gradc(3,-1:nres,0:2))
19941 !(3,maxres,2)
19942       allocate(gvdwx(3,-1:nres))
19943       allocate(gvdwc(3,-1:nres))
19944       allocate(gelc(3,-1:nres))
19945       allocate(gelc_long(3,-1:nres))
19946       allocate(gvdwpp(3,-1:nres))
19947       allocate(gvdwc_scpp(3,-1:nres))
19948       allocate(gradx_scp(3,-1:nres))
19949       allocate(gvdwc_scp(3,-1:nres))
19950       allocate(ghpbx(3,-1:nres))
19951       allocate(ghpbc(3,-1:nres))
19952       allocate(gradcorr(3,-1:nres))
19953       allocate(gradcorr_long(3,-1:nres))
19954       allocate(gradcorr5_long(3,-1:nres))
19955       allocate(gradcorr6_long(3,-1:nres))
19956       allocate(gcorr6_turn_long(3,-1:nres))
19957       allocate(gradxorr(3,-1:nres))
19958       allocate(gradcorr5(3,-1:nres))
19959       allocate(gradcorr6(3,-1:nres))
19960       allocate(gliptran(3,-1:nres))
19961       allocate(gliptranc(3,-1:nres))
19962       allocate(gliptranx(3,-1:nres))
19963       allocate(gshieldx(3,-1:nres))
19964       allocate(gshieldc(3,-1:nres))
19965       allocate(gshieldc_loc(3,-1:nres))
19966       allocate(gshieldx_ec(3,-1:nres))
19967       allocate(gshieldc_ec(3,-1:nres))
19968       allocate(gshieldc_loc_ec(3,-1:nres))
19969       allocate(gshieldx_t3(3,-1:nres))
19970       allocate(gshieldc_t3(3,-1:nres))
19971       allocate(gshieldc_loc_t3(3,-1:nres))
19972       allocate(gshieldx_t4(3,-1:nres))
19973       allocate(gshieldc_t4(3,-1:nres))
19974       allocate(gshieldc_loc_t4(3,-1:nres))
19975       allocate(gshieldx_ll(3,-1:nres))
19976       allocate(gshieldc_ll(3,-1:nres))
19977       allocate(gshieldc_loc_ll(3,-1:nres))
19978       allocate(grad_shield(3,-1:nres))
19979       allocate(gg_tube_sc(3,-1:nres))
19980       allocate(gg_tube(3,-1:nres))
19981       allocate(gradafm(3,-1:nres))
19982       allocate(gradb_nucl(3,-1:nres))
19983       allocate(gradbx_nucl(3,-1:nres))
19984       allocate(gvdwpsb1(3,-1:nres))
19985       allocate(gelpp(3,-1:nres))
19986       allocate(gvdwpsb(3,-1:nres))
19987       allocate(gelsbc(3,-1:nres))
19988       allocate(gelsbx(3,-1:nres))
19989       allocate(gvdwsbx(3,-1:nres))
19990       allocate(gvdwsbc(3,-1:nres))
19991       allocate(gsbloc(3,-1:nres))
19992       allocate(gsblocx(3,-1:nres))
19993       allocate(gradcorr_nucl(3,-1:nres))
19994       allocate(gradxorr_nucl(3,-1:nres))
19995       allocate(gradcorr3_nucl(3,-1:nres))
19996       allocate(gradxorr3_nucl(3,-1:nres))
19997       allocate(gvdwpp_nucl(3,-1:nres))
19998       allocate(gradpepcat(3,-1:nres))
19999       allocate(gradpepcatx(3,-1:nres))
20000       allocate(gradcatcat(3,-1:nres))
20001 !(3,maxres)
20002       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
20003       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
20004 ! grad for shielding surroing
20005       allocate(gloc(0:maxvar,0:2))
20006       allocate(gloc_x(0:maxvar,2))
20007 !(maxvar,2)
20008       allocate(gel_loc(3,-1:nres))
20009       allocate(gel_loc_long(3,-1:nres))
20010       allocate(gcorr3_turn(3,-1:nres))
20011       allocate(gcorr4_turn(3,-1:nres))
20012       allocate(gcorr6_turn(3,-1:nres))
20013       allocate(gradb(3,-1:nres))
20014       allocate(gradbx(3,-1:nres))
20015 !(3,maxres)
20016       allocate(gel_loc_loc(maxvar))
20017       allocate(gel_loc_turn3(maxvar))
20018       allocate(gel_loc_turn4(maxvar))
20019       allocate(gel_loc_turn6(maxvar))
20020       allocate(gcorr_loc(maxvar))
20021       allocate(g_corr5_loc(maxvar))
20022       allocate(g_corr6_loc(maxvar))
20023 !(maxvar)
20024       allocate(gsccorc(3,-1:nres))
20025       allocate(gsccorx(3,-1:nres))
20026 !(3,maxres)
20027       allocate(gsccor_loc(-1:nres))
20028 !(maxres)
20029       allocate(gvdwx_scbase(3,-1:nres))
20030       allocate(gvdwc_scbase(3,-1:nres))
20031       allocate(gvdwx_pepbase(3,-1:nres))
20032       allocate(gvdwc_pepbase(3,-1:nres))
20033       allocate(gvdwx_scpho(3,-1:nres))
20034       allocate(gvdwc_scpho(3,-1:nres))
20035       allocate(gvdwc_peppho(3,-1:nres))
20036
20037       allocate(dtheta(3,2,-1:nres))
20038 !(3,2,maxres)
20039       allocate(gscloc(3,-1:nres))
20040       allocate(gsclocx(3,-1:nres))
20041 !(3,maxres)
20042       allocate(dphi(3,3,-1:nres))
20043       allocate(dalpha(3,3,-1:nres))
20044       allocate(domega(3,3,-1:nres))
20045 !(3,3,maxres)
20046 !      common /deriv_scloc/
20047       allocate(dXX_C1tab(3,nres))
20048       allocate(dYY_C1tab(3,nres))
20049       allocate(dZZ_C1tab(3,nres))
20050       allocate(dXX_Ctab(3,nres))
20051       allocate(dYY_Ctab(3,nres))
20052       allocate(dZZ_Ctab(3,nres))
20053       allocate(dXX_XYZtab(3,nres))
20054       allocate(dYY_XYZtab(3,nres))
20055       allocate(dZZ_XYZtab(3,nres))
20056 !(3,maxres)
20057 !      common /mpgrad/
20058       allocate(jgrad_start(nres))
20059       allocate(jgrad_end(nres))
20060 !(maxres)
20061 !----------------------
20062
20063 !      common /indices/
20064       allocate(ibond_displ(0:nfgtasks-1))
20065       allocate(ibond_count(0:nfgtasks-1))
20066       allocate(ithet_displ(0:nfgtasks-1))
20067       allocate(ithet_count(0:nfgtasks-1))
20068       allocate(iphi_displ(0:nfgtasks-1))
20069       allocate(iphi_count(0:nfgtasks-1))
20070       allocate(iphi1_displ(0:nfgtasks-1))
20071       allocate(iphi1_count(0:nfgtasks-1))
20072       allocate(ivec_displ(0:nfgtasks-1))
20073       allocate(ivec_count(0:nfgtasks-1))
20074       allocate(iset_displ(0:nfgtasks-1))
20075       allocate(iset_count(0:nfgtasks-1))
20076       allocate(iint_count(0:nfgtasks-1))
20077       allocate(iint_displ(0:nfgtasks-1))
20078 !(0:max_fg_procs-1)
20079 !----------------------
20080 ! common.MD
20081 !      common /mdgrad/
20082       allocate(gcart(3,-1:nres))
20083       allocate(gxcart(3,-1:nres))
20084 !(3,0:MAXRES)
20085       allocate(gradcag(3,-1:nres))
20086       allocate(gradxag(3,-1:nres))
20087 !(3,MAXRES)
20088 !      common /back_constr/
20089 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
20090       allocate(dutheta(nres))
20091       allocate(dugamma(nres))
20092 !(maxres)
20093       allocate(duscdiff(3,nres))
20094       allocate(duscdiffx(3,nres))
20095 !(3,maxres)
20096 !el i io:read_fragments
20097 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
20098 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
20099 !      common /qmeas/
20100 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
20101 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
20102       allocate(mset(0:nprocs))  !(maxprocs/20)
20103       mset(:)=0
20104 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
20105 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
20106       allocate(dUdconst(3,0:nres))
20107       allocate(dUdxconst(3,0:nres))
20108       allocate(dqwol(3,0:nres))
20109       allocate(dxqwol(3,0:nres))
20110 !(3,0:MAXRES)
20111 !----------------------
20112 ! common.sbridge
20113 !      common /sbridge/ in io_common: read_bridge
20114 !el    allocate((:),allocatable :: iss      !(maxss)
20115 !      common /links/  in io_common: read_bridge
20116 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
20117 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
20118 !      common /dyn_ssbond/
20119 ! and side-chain vectors in theta or phi.
20120       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
20121 !(maxres,maxres)
20122 !      do i=1,nres
20123 !        do j=i+1,nres
20124       dyn_ssbond_ij(:,:)=1.0d300
20125 !        enddo
20126 !      enddo
20127
20128 !      if (nss.gt.0) then
20129         allocate(idssb(maxdim),jdssb(maxdim))
20130 !        allocate(newihpb(nss),newjhpb(nss))
20131 !(maxdim)
20132 !      endif
20133       allocate(ishield_list(-1:nres))
20134       allocate(shield_list(maxcontsshi,-1:nres))
20135       allocate(dyn_ss_mask(nres))
20136       allocate(fac_shield(-1:nres))
20137       allocate(enetube(nres*2))
20138       allocate(enecavtube(nres*2))
20139
20140 !(maxres)
20141       dyn_ss_mask(:)=.false.
20142 !----------------------
20143 ! common.sccor
20144 ! Parameters of the SCCOR term
20145 !      common/sccor/
20146 !el in io_conf: parmread
20147 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
20148 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
20149 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
20150 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
20151 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
20152 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
20153 !      allocate(vlor1sccor(maxterm_sccor,20,20))
20154 !      allocate(vlor2sccor(maxterm_sccor,20,20))
20155 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
20156 !----------------
20157       allocate(gloc_sc(3,0:2*nres,0:10))
20158 !(3,0:maxres2,10)maxres2=2*maxres
20159       allocate(dcostau(3,3,3,2*nres))
20160       allocate(dsintau(3,3,3,2*nres))
20161       allocate(dtauangle(3,3,3,2*nres))
20162       allocate(dcosomicron(3,3,3,2*nres))
20163       allocate(domicron(3,3,3,2*nres))
20164 !(3,3,3,maxres2)maxres2=2*maxres
20165 !----------------------
20166 ! common.var
20167 !      common /restr/
20168       allocate(varall(maxvar))
20169 !(maxvar)(maxvar=6*maxres)
20170       allocate(mask_theta(nres))
20171       allocate(mask_phi(nres))
20172       allocate(mask_side(nres))
20173 !(maxres)
20174 !----------------------
20175 ! common.vectors
20176 !      common /vectors/
20177       allocate(uy(3,nres))
20178       allocate(uz(3,nres))
20179 !(3,maxres)
20180       allocate(uygrad(3,3,2,nres))
20181       allocate(uzgrad(3,3,2,nres))
20182 !(3,3,2,maxres)
20183
20184       return
20185       end subroutine alloc_ener_arrays
20186 !-----------------------------------------------------------------
20187       subroutine ebond_nucl(estr_nucl)
20188 !c
20189 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20190 !c
20191
20192       real(kind=8),dimension(3) :: u,ud
20193       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20194       real(kind=8) :: estr_nucl,diff
20195       integer :: iti,i,j,k,nbi
20196       estr_nucl=0.0d0
20197 !C      print *,"I enter ebond"
20198       if (energy_dec) &
20199       write (iout,*) "ibondp_start,ibondp_end",&
20200        ibondp_nucl_start,ibondp_nucl_end
20201       do i=ibondp_nucl_start,ibondp_nucl_end
20202         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20203          itype(i,2).eq.ntyp1_molec(2)) cycle
20204 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20205 !          do j=1,3
20206 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20207 !     &      *dc(j,i-1)/vbld(i)
20208 !          enddo
20209 !          if (energy_dec) write(iout,*)
20210 !     &       "estr1",i,vbld(i),distchainmax,
20211 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20212
20213           diff = vbld(i)-vbldp0_nucl
20214           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20215           vbldp0_nucl,diff,AKP_nucl*diff*diff
20216           estr_nucl=estr_nucl+diff*diff
20217 !          print *,estr_nucl
20218           do j=1,3
20219             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20220           enddo
20221 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20222       enddo
20223       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20224 !      print *,"partial sum", estr_nucl,AKP_nucl
20225
20226       if (energy_dec) &
20227       write (iout,*) "ibondp_start,ibondp_end",&
20228        ibond_nucl_start,ibond_nucl_end
20229
20230       do i=ibond_nucl_start,ibond_nucl_end
20231 !C        print *, "I am stuck",i
20232         iti=itype(i,2)
20233         if (iti.eq.ntyp1_molec(2)) cycle
20234           nbi=nbondterm_nucl(iti)
20235 !C        print *,iti,nbi
20236           if (nbi.eq.1) then
20237             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20238
20239             if (energy_dec) &
20240            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20241            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20242             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20243 !            print *,estr_nucl
20244             do j=1,3
20245               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20246             enddo
20247           else
20248             do j=1,nbi
20249               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20250               ud(j)=aksc_nucl(j,iti)*diff
20251               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20252             enddo
20253             uprod=u(1)
20254             do j=2,nbi
20255               uprod=uprod*u(j)
20256             enddo
20257             usum=0.0d0
20258             usumsqder=0.0d0
20259             do j=1,nbi
20260               uprod1=1.0d0
20261               uprod2=1.0d0
20262               do k=1,nbi
20263                 if (k.ne.j) then
20264                   uprod1=uprod1*u(k)
20265                   uprod2=uprod2*u(k)*u(k)
20266                 endif
20267               enddo
20268               usum=usum+uprod1
20269               usumsqder=usumsqder+ud(j)*uprod2
20270             enddo
20271             estr_nucl=estr_nucl+uprod/usum
20272             do j=1,3
20273              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20274             enddo
20275         endif
20276       enddo
20277 !C      print *,"I am about to leave ebond"
20278       return
20279       end subroutine ebond_nucl
20280
20281 !-----------------------------------------------------------------------------
20282       subroutine ebend_nucl(etheta_nucl)
20283       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20284       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20285       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20286       logical :: lprn=.false., lprn1=.false.
20287 !el local variables
20288       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20289       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20290       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20291 ! local variables for constrains
20292       real(kind=8) :: difi,thetiii
20293        integer itheta
20294       etheta_nucl=0.0D0
20295 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20296       do i=ithet_nucl_start,ithet_nucl_end
20297         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20298         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20299         (itype(i,2).eq.ntyp1_molec(2))) cycle
20300         dethetai=0.0d0
20301         dephii=0.0d0
20302         dephii1=0.0d0
20303         theti2=0.5d0*theta(i)
20304         ityp2=ithetyp_nucl(itype(i-1,2))
20305         do k=1,nntheterm_nucl
20306           coskt(k)=dcos(k*theti2)
20307           sinkt(k)=dsin(k*theti2)
20308         enddo
20309         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20310 #ifdef OSF
20311           phii=phi(i)
20312           if (phii.ne.phii) phii=150.0
20313 #else
20314           phii=phi(i)
20315 #endif
20316           ityp1=ithetyp_nucl(itype(i-2,2))
20317           do k=1,nsingle_nucl
20318             cosph1(k)=dcos(k*phii)
20319             sinph1(k)=dsin(k*phii)
20320           enddo
20321         else
20322           phii=0.0d0
20323           ityp1=nthetyp_nucl+1
20324           do k=1,nsingle_nucl
20325             cosph1(k)=0.0d0
20326             sinph1(k)=0.0d0
20327           enddo
20328         endif
20329
20330         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20331 #ifdef OSF
20332           phii1=phi(i+1)
20333           if (phii1.ne.phii1) phii1=150.0
20334           phii1=pinorm(phii1)
20335 #else
20336           phii1=phi(i+1)
20337 #endif
20338           ityp3=ithetyp_nucl(itype(i,2))
20339           do k=1,nsingle_nucl
20340             cosph2(k)=dcos(k*phii1)
20341             sinph2(k)=dsin(k*phii1)
20342           enddo
20343         else
20344           phii1=0.0d0
20345           ityp3=nthetyp_nucl+1
20346           do k=1,nsingle_nucl
20347             cosph2(k)=0.0d0
20348             sinph2(k)=0.0d0
20349           enddo
20350         endif
20351         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
20352         do k=1,ndouble_nucl
20353           do l=1,k-1
20354             ccl=cosph1(l)*cosph2(k-l)
20355             ssl=sinph1(l)*sinph2(k-l)
20356             scl=sinph1(l)*cosph2(k-l)
20357             csl=cosph1(l)*sinph2(k-l)
20358             cosph1ph2(l,k)=ccl-ssl
20359             cosph1ph2(k,l)=ccl+ssl
20360             sinph1ph2(l,k)=scl+csl
20361             sinph1ph2(k,l)=scl-csl
20362           enddo
20363         enddo
20364         if (lprn) then
20365         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
20366          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
20367         write (iout,*) "coskt and sinkt",nntheterm_nucl
20368         do k=1,nntheterm_nucl
20369           write (iout,*) k,coskt(k),sinkt(k)
20370         enddo
20371         endif
20372         do k=1,ntheterm_nucl
20373           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
20374           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
20375            *coskt(k)
20376           if (lprn)&
20377          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
20378           " ethetai",ethetai
20379         enddo
20380         if (lprn) then
20381         write (iout,*) "cosph and sinph"
20382         do k=1,nsingle_nucl
20383           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
20384         enddo
20385         write (iout,*) "cosph1ph2 and sinph2ph2"
20386         do k=2,ndouble_nucl
20387           do l=1,k-1
20388             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
20389               sinph1ph2(l,k),sinph1ph2(k,l)
20390           enddo
20391         enddo
20392         write(iout,*) "ethetai",ethetai
20393         endif
20394         do m=1,ntheterm2_nucl
20395           do k=1,nsingle_nucl
20396             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
20397               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
20398               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
20399               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
20400             ethetai=ethetai+sinkt(m)*aux
20401             dethetai=dethetai+0.5d0*m*aux*coskt(m)
20402             dephii=dephii+k*sinkt(m)*(&
20403                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
20404                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
20405             dephii1=dephii1+k*sinkt(m)*(&
20406                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
20407                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
20408             if (lprn) &
20409            write (iout,*) "m",m," k",k," bbthet",&
20410               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
20411               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
20412               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
20413               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20414           enddo
20415         enddo
20416         if (lprn) &
20417         write(iout,*) "ethetai",ethetai
20418         do m=1,ntheterm3_nucl
20419           do k=2,ndouble_nucl
20420             do l=1,k-1
20421               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20422                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
20423                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20424                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
20425               ethetai=ethetai+sinkt(m)*aux
20426               dethetai=dethetai+0.5d0*m*coskt(m)*aux
20427               dephii=dephii+l*sinkt(m)*(&
20428                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
20429                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20430                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20431                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20432               dephii1=dephii1+(k-l)*sinkt(m)*( &
20433                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20434                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20435                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
20436                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20437               if (lprn) then
20438               write (iout,*) "m",m," k",k," l",l," ffthet", &
20439                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
20440                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
20441                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
20442                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20443               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
20444                  cosph1ph2(k,l)*sinkt(m),&
20445                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
20446               endif
20447             enddo
20448           enddo
20449         enddo
20450 10      continue
20451         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
20452         i,theta(i)*rad2deg,phii*rad2deg, &
20453         phii1*rad2deg,ethetai
20454         etheta_nucl=etheta_nucl+ethetai
20455 !        print *,i,"partial sum",etheta_nucl
20456         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
20457         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
20458         gloc(nphi+i-2,icg)=wang_nucl*dethetai
20459       enddo
20460       return
20461       end subroutine ebend_nucl
20462 !----------------------------------------------------
20463       subroutine etor_nucl(etors_nucl)
20464 !      implicit real*8 (a-h,o-z)
20465 !      include 'DIMENSIONS'
20466 !      include 'COMMON.VAR'
20467 !      include 'COMMON.GEO'
20468 !      include 'COMMON.LOCAL'
20469 !      include 'COMMON.TORSION'
20470 !      include 'COMMON.INTERACT'
20471 !      include 'COMMON.DERIV'
20472 !      include 'COMMON.CHAIN'
20473 !      include 'COMMON.NAMES'
20474 !      include 'COMMON.IOUNITS'
20475 !      include 'COMMON.FFIELD'
20476 !      include 'COMMON.TORCNSTR'
20477 !      include 'COMMON.CONTROL'
20478       real(kind=8) :: etors_nucl,edihcnstr
20479       logical :: lprn
20480 !el local variables
20481       integer :: i,j,iblock,itori,itori1
20482       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
20483                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
20484 ! Set lprn=.true. for debugging
20485       lprn=.false.
20486 !     lprn=.true.
20487       etors_nucl=0.0D0
20488 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
20489       do i=iphi_nucl_start,iphi_nucl_end
20490         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
20491              .or. itype(i-3,2).eq.ntyp1_molec(2) &
20492              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
20493         etors_ii=0.0D0
20494         itori=itortyp_nucl(itype(i-2,2))
20495         itori1=itortyp_nucl(itype(i-1,2))
20496         phii=phi(i)
20497 !         print *,i,itori,itori1
20498         gloci=0.0D0
20499 !C Regular cosine and sine terms
20500         do j=1,nterm_nucl(itori,itori1)
20501           v1ij=v1_nucl(j,itori,itori1)
20502           v2ij=v2_nucl(j,itori,itori1)
20503           cosphi=dcos(j*phii)
20504           sinphi=dsin(j*phii)
20505           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
20506           if (energy_dec) etors_ii=etors_ii+&
20507                      v1ij*cosphi+v2ij*sinphi
20508           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
20509         enddo
20510 !C Lorentz terms
20511 !C                         v1
20512 !C  E = SUM ----------------------------------- - v1
20513 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
20514 !C
20515         cosphi=dcos(0.5d0*phii)
20516         sinphi=dsin(0.5d0*phii)
20517         do j=1,nlor_nucl(itori,itori1)
20518           vl1ij=vlor1_nucl(j,itori,itori1)
20519           vl2ij=vlor2_nucl(j,itori,itori1)
20520           vl3ij=vlor3_nucl(j,itori,itori1)
20521           pom=vl2ij*cosphi+vl3ij*sinphi
20522           pom1=1.0d0/(pom*pom+1.0d0)
20523           etors_nucl=etors_nucl+vl1ij*pom1
20524           if (energy_dec) etors_ii=etors_ii+ &
20525                      vl1ij*pom1
20526           pom=-pom*pom1*pom1
20527           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
20528         enddo
20529 !C Subtract the constant term
20530         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
20531           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
20532               'etor',i,etors_ii-v0_nucl(itori,itori1)
20533         if (lprn) &
20534        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
20535        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
20536        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
20537         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
20538 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
20539       enddo
20540       return
20541       end subroutine etor_nucl
20542 !------------------------------------------------------------
20543       subroutine epp_nucl_sub(evdw1,ees)
20544 !C
20545 !C This subroutine calculates the average interaction energy and its gradient
20546 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
20547 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
20548 !C The potential depends both on the distance of peptide-group centers and on
20549 !C the orientation of the CA-CA virtual bonds.
20550 !C
20551       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
20552       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
20553       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
20554                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
20555                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
20556       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20557                     dist_temp, dist_init,sss_grad,fac,evdw1ij
20558       integer xshift,yshift,zshift
20559       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
20560       real(kind=8) :: ees,eesij
20561 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20562       real(kind=8) scal_el /0.5d0/
20563       t_eelecij=0.0d0
20564       ees=0.0D0
20565       evdw1=0.0D0
20566       ind=0
20567 !c
20568 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
20569 !c
20570 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
20571       do i=iatel_s_nucl,iatel_e_nucl
20572         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20573         dxi=dc(1,i)
20574         dyi=dc(2,i)
20575         dzi=dc(3,i)
20576         dx_normi=dc_norm(1,i)
20577         dy_normi=dc_norm(2,i)
20578         dz_normi=dc_norm(3,i)
20579         xmedi=c(1,i)+0.5d0*dxi
20580         ymedi=c(2,i)+0.5d0*dyi
20581         zmedi=c(3,i)+0.5d0*dzi
20582           xmedi=dmod(xmedi,boxxsize)
20583           if (xmedi.lt.0) xmedi=xmedi+boxxsize
20584           ymedi=dmod(ymedi,boxysize)
20585           if (ymedi.lt.0) ymedi=ymedi+boxysize
20586           zmedi=dmod(zmedi,boxzsize)
20587           if (zmedi.lt.0) zmedi=zmedi+boxzsize
20588
20589         do j=ielstart_nucl(i),ielend_nucl(i)
20590           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
20591           ind=ind+1
20592           dxj=dc(1,j)
20593           dyj=dc(2,j)
20594           dzj=dc(3,j)
20595 !          xj=c(1,j)+0.5D0*dxj-xmedi
20596 !          yj=c(2,j)+0.5D0*dyj-ymedi
20597 !          zj=c(3,j)+0.5D0*dzj-zmedi
20598           xj=c(1,j)+0.5D0*dxj
20599           yj=c(2,j)+0.5D0*dyj
20600           zj=c(3,j)+0.5D0*dzj
20601           xj=mod(xj,boxxsize)
20602           if (xj.lt.0) xj=xj+boxxsize
20603           yj=mod(yj,boxysize)
20604           if (yj.lt.0) yj=yj+boxysize
20605           zj=mod(zj,boxzsize)
20606           if (zj.lt.0) zj=zj+boxzsize
20607       isubchap=0
20608       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20609       xj_safe=xj
20610       yj_safe=yj
20611       zj_safe=zj
20612       do xshift=-1,1
20613       do yshift=-1,1
20614       do zshift=-1,1
20615           xj=xj_safe+xshift*boxxsize
20616           yj=yj_safe+yshift*boxysize
20617           zj=zj_safe+zshift*boxzsize
20618           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20619           if(dist_temp.lt.dist_init) then
20620             dist_init=dist_temp
20621             xj_temp=xj
20622             yj_temp=yj
20623             zj_temp=zj
20624             isubchap=1
20625           endif
20626        enddo
20627        enddo
20628        enddo
20629        if (isubchap.eq.1) then
20630 !C          print *,i,j
20631           xj=xj_temp-xmedi
20632           yj=yj_temp-ymedi
20633           zj=zj_temp-zmedi
20634        else
20635           xj=xj_safe-xmedi
20636           yj=yj_safe-ymedi
20637           zj=zj_safe-zmedi
20638        endif
20639
20640           rij=xj*xj+yj*yj+zj*zj
20641 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
20642           fac=(r0pp**2/rij)**3
20643           ev1=epspp*fac*fac
20644           ev2=epspp*fac
20645           evdw1ij=ev1-2*ev2
20646           fac=(-ev1-evdw1ij)/rij
20647 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
20648           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
20649           evdw1=evdw1+evdw1ij
20650 !C
20651 !C Calculate contributions to the Cartesian gradient.
20652 !C
20653           ggg(1)=fac*xj
20654           ggg(2)=fac*yj
20655           ggg(3)=fac*zj
20656           do k=1,3
20657             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
20658             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
20659           enddo
20660 !c phoshate-phosphate electrostatic interactions
20661           rij=dsqrt(rij)
20662           fac=1.0d0/rij
20663           eesij=dexp(-BEES*rij)*fac
20664 !          write (2,*)"fac",fac," eesijpp",eesij
20665           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
20666           ees=ees+eesij
20667 !c          fac=-eesij*fac
20668           fac=-(fac+BEES)*eesij*fac
20669           ggg(1)=fac*xj
20670           ggg(2)=fac*yj
20671           ggg(3)=fac*zj
20672 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
20673 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
20674 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
20675           do k=1,3
20676             gelpp(k,i)=gelpp(k,i)-ggg(k)
20677             gelpp(k,j)=gelpp(k,j)+ggg(k)
20678           enddo
20679         enddo ! j
20680       enddo   ! i
20681 !c      ees=332.0d0*ees
20682       ees=AEES*ees
20683       do i=nnt,nct
20684 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20685         do k=1,3
20686           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
20687 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
20688           gelpp(k,i)=AEES*gelpp(k,i)
20689         enddo
20690 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20691       enddo
20692 !c      write (2,*) "total EES",ees
20693       return
20694       end subroutine epp_nucl_sub
20695 !---------------------------------------------------------------------
20696       subroutine epsb(evdwpsb,eelpsb)
20697 !      use comm_locel
20698 !C
20699 !C This subroutine calculates the excluded-volume interaction energy between
20700 !C peptide-group centers and side chains and its gradient in virtual-bond and
20701 !C side-chain vectors.
20702 !C
20703       real(kind=8),dimension(3):: ggg
20704       integer :: i,iint,j,k,iteli,itypj,subchap
20705       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
20706                    e1,e2,evdwij,rij,evdwpsb,eelpsb
20707       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20708                     dist_temp, dist_init
20709       integer xshift,yshift,zshift
20710
20711 !cd    print '(a)','Enter ESCP'
20712 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
20713       eelpsb=0.0d0
20714       evdwpsb=0.0d0
20715 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
20716       do i=iatscp_s_nucl,iatscp_e_nucl
20717         if (itype(i,2).eq.ntyp1_molec(2) &
20718          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20719         xi=0.5D0*(c(1,i)+c(1,i+1))
20720         yi=0.5D0*(c(2,i)+c(2,i+1))
20721         zi=0.5D0*(c(3,i)+c(3,i+1))
20722           xi=mod(xi,boxxsize)
20723           if (xi.lt.0) xi=xi+boxxsize
20724           yi=mod(yi,boxysize)
20725           if (yi.lt.0) yi=yi+boxysize
20726           zi=mod(zi,boxzsize)
20727           if (zi.lt.0) zi=zi+boxzsize
20728
20729         do iint=1,nscp_gr_nucl(i)
20730
20731         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
20732           itypj=itype(j,2)
20733           if (itypj.eq.ntyp1_molec(2)) cycle
20734 !C Uncomment following three lines for SC-p interactions
20735 !c         xj=c(1,nres+j)-xi
20736 !c         yj=c(2,nres+j)-yi
20737 !c         zj=c(3,nres+j)-zi
20738 !C Uncomment following three lines for Ca-p interactions
20739 !          xj=c(1,j)-xi
20740 !          yj=c(2,j)-yi
20741 !          zj=c(3,j)-zi
20742           xj=c(1,j)
20743           yj=c(2,j)
20744           zj=c(3,j)
20745           xj=mod(xj,boxxsize)
20746           if (xj.lt.0) xj=xj+boxxsize
20747           yj=mod(yj,boxysize)
20748           if (yj.lt.0) yj=yj+boxysize
20749           zj=mod(zj,boxzsize)
20750           if (zj.lt.0) zj=zj+boxzsize
20751       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20752       xj_safe=xj
20753       yj_safe=yj
20754       zj_safe=zj
20755       subchap=0
20756       do xshift=-1,1
20757       do yshift=-1,1
20758       do zshift=-1,1
20759           xj=xj_safe+xshift*boxxsize
20760           yj=yj_safe+yshift*boxysize
20761           zj=zj_safe+zshift*boxzsize
20762           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20763           if(dist_temp.lt.dist_init) then
20764             dist_init=dist_temp
20765             xj_temp=xj
20766             yj_temp=yj
20767             zj_temp=zj
20768             subchap=1
20769           endif
20770        enddo
20771        enddo
20772        enddo
20773        if (subchap.eq.1) then
20774           xj=xj_temp-xi
20775           yj=yj_temp-yi
20776           zj=zj_temp-zi
20777        else
20778           xj=xj_safe-xi
20779           yj=yj_safe-yi
20780           zj=zj_safe-zi
20781        endif
20782
20783           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20784           fac=rrij**expon2
20785           e1=fac*fac*aad_nucl(itypj)
20786           e2=fac*bad_nucl(itypj)
20787           if (iabs(j-i) .le. 2) then
20788             e1=scal14*e1
20789             e2=scal14*e2
20790           endif
20791           evdwij=e1+e2
20792           evdwpsb=evdwpsb+evdwij
20793           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
20794              'evdw2',i,j,evdwij,"tu4"
20795 !C
20796 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
20797 !C
20798           fac=-(evdwij+e1)*rrij
20799           ggg(1)=xj*fac
20800           ggg(2)=yj*fac
20801           ggg(3)=zj*fac
20802           do k=1,3
20803             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
20804             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
20805           enddo
20806         enddo
20807
20808         enddo ! iint
20809       enddo ! i
20810       do i=1,nct
20811         do j=1,3
20812           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
20813           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
20814         enddo
20815       enddo
20816       return
20817       end subroutine epsb
20818
20819 !------------------------------------------------------
20820       subroutine esb_gb(evdwsb,eelsb)
20821       use comm_locel
20822       use calc_data_nucl
20823       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
20824       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
20825       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
20826       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20827                     dist_temp, dist_init,aa,bb,faclip,sig0ij
20828       integer :: ii
20829       logical lprn
20830       evdw=0.0D0
20831       eelsb=0.0d0
20832       ecorr=0.0d0
20833       evdwsb=0.0D0
20834       lprn=.false.
20835       ind=0
20836 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
20837       do i=iatsc_s_nucl,iatsc_e_nucl
20838         num_conti=0
20839         num_conti2=0
20840         itypi=itype(i,2)
20841 !        PRINT *,"I=",i,itypi
20842         if (itypi.eq.ntyp1_molec(2)) cycle
20843         itypi1=itype(i+1,2)
20844         xi=c(1,nres+i)
20845         yi=c(2,nres+i)
20846         zi=c(3,nres+i)
20847           xi=dmod(xi,boxxsize)
20848           if (xi.lt.0) xi=xi+boxxsize
20849           yi=dmod(yi,boxysize)
20850           if (yi.lt.0) yi=yi+boxysize
20851           zi=dmod(zi,boxzsize)
20852           if (zi.lt.0) zi=zi+boxzsize
20853
20854         dxi=dc_norm(1,nres+i)
20855         dyi=dc_norm(2,nres+i)
20856         dzi=dc_norm(3,nres+i)
20857         dsci_inv=vbld_inv(i+nres)
20858 !C
20859 !C Calculate SC interaction energy.
20860 !C
20861         do iint=1,nint_gr_nucl(i)
20862 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
20863           do j=istart_nucl(i,iint),iend_nucl(i,iint)
20864             ind=ind+1
20865 !            print *,"JESTEM"
20866             itypj=itype(j,2)
20867             if (itypj.eq.ntyp1_molec(2)) cycle
20868             dscj_inv=vbld_inv(j+nres)
20869             sig0ij=sigma_nucl(itypi,itypj)
20870             chi1=chi_nucl(itypi,itypj)
20871             chi2=chi_nucl(itypj,itypi)
20872             chi12=chi1*chi2
20873             chip1=chip_nucl(itypi,itypj)
20874             chip2=chip_nucl(itypj,itypi)
20875             chip12=chip1*chip2
20876 !            xj=c(1,nres+j)-xi
20877 !            yj=c(2,nres+j)-yi
20878 !            zj=c(3,nres+j)-zi
20879            xj=c(1,nres+j)
20880            yj=c(2,nres+j)
20881            zj=c(3,nres+j)
20882           xj=dmod(xj,boxxsize)
20883           if (xj.lt.0) xj=xj+boxxsize
20884           yj=dmod(yj,boxysize)
20885           if (yj.lt.0) yj=yj+boxysize
20886           zj=dmod(zj,boxzsize)
20887           if (zj.lt.0) zj=zj+boxzsize
20888       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20889       xj_safe=xj
20890       yj_safe=yj
20891       zj_safe=zj
20892       subchap=0
20893       do xshift=-1,1
20894       do yshift=-1,1
20895       do zshift=-1,1
20896           xj=xj_safe+xshift*boxxsize
20897           yj=yj_safe+yshift*boxysize
20898           zj=zj_safe+zshift*boxzsize
20899           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20900           if(dist_temp.lt.dist_init) then
20901             dist_init=dist_temp
20902             xj_temp=xj
20903             yj_temp=yj
20904             zj_temp=zj
20905             subchap=1
20906           endif
20907        enddo
20908        enddo
20909        enddo
20910        if (subchap.eq.1) then
20911           xj=xj_temp-xi
20912           yj=yj_temp-yi
20913           zj=zj_temp-zi
20914        else
20915           xj=xj_safe-xi
20916           yj=yj_safe-yi
20917           zj=zj_safe-zi
20918        endif
20919
20920             dxj=dc_norm(1,nres+j)
20921             dyj=dc_norm(2,nres+j)
20922             dzj=dc_norm(3,nres+j)
20923             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20924             rij=dsqrt(rrij)
20925 !C Calculate angle-dependent terms of energy and contributions to their
20926 !C derivatives.
20927             erij(1)=xj*rij
20928             erij(2)=yj*rij
20929             erij(3)=zj*rij
20930             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
20931             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
20932             om12=dxi*dxj+dyi*dyj+dzi*dzj
20933             call sc_angular_nucl
20934             sigsq=1.0D0/sigsq
20935             sig=sig0ij*dsqrt(sigsq)
20936             rij_shift=1.0D0/rij-sig+sig0ij
20937 !            print *,rij_shift,"rij_shift"
20938 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
20939 !c     &       " rij_shift",rij_shift
20940             if (rij_shift.le.0.0D0) then
20941               evdw=1.0D20
20942               return
20943             endif
20944             sigder=-sig*sigsq
20945 !c---------------------------------------------------------------
20946             rij_shift=1.0D0/rij_shift
20947             fac=rij_shift**expon
20948             e1=fac*fac*aa_nucl(itypi,itypj)
20949             e2=fac*bb_nucl(itypi,itypj)
20950             evdwij=eps1*eps2rt*(e1+e2)
20951 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
20952 !c     &       " e1",e1," e2",e2," evdwij",evdwij
20953             eps2der=evdwij
20954             evdwij=evdwij*eps2rt
20955             evdwsb=evdwsb+evdwij
20956             if (lprn) then
20957             sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
20958             epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
20959             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
20960              restyp(itypi,2),i,restyp(itypj,2),j, &
20961              epsi,sigm,chi1,chi2,chip1,chip2, &
20962              eps1,eps2rt**2,sig,sig0ij, &
20963              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
20964             evdwij
20965             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
20966             endif
20967
20968             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
20969                              'evdw',i,j,evdwij,"tu3"
20970
20971
20972 !C Calculate gradient components.
20973             e1=e1*eps1*eps2rt**2
20974             fac=-expon*(e1+evdwij)*rij_shift
20975             sigder=fac*sigder
20976             fac=rij*fac
20977 !c            fac=0.0d0
20978 !C Calculate the radial part of the gradient
20979             gg(1)=xj*fac
20980             gg(2)=yj*fac
20981             gg(3)=zj*fac
20982 !C Calculate angular part of the gradient.
20983             call sc_grad_nucl
20984             call eelsbij(eelij,num_conti2)
20985             if (energy_dec .and. &
20986            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
20987           write (istat,'(e14.5)') evdwij
20988             eelsb=eelsb+eelij
20989           enddo      ! j
20990         enddo        ! iint
20991         num_cont_hb(i)=num_conti2
20992       enddo          ! i
20993 !c      write (iout,*) "Number of loop steps in EGB:",ind
20994 !cccc      energy_dec=.false.
20995       return
20996       end subroutine esb_gb
20997 !-------------------------------------------------------------------------------
20998       subroutine eelsbij(eesij,num_conti2)
20999       use comm_locel
21000       use calc_data_nucl
21001       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
21002       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
21003       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21004                     dist_temp, dist_init,rlocshield,fracinbuf
21005       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
21006
21007 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21008       real(kind=8) scal_el /0.5d0/
21009       integer :: iteli,itelj,kkk,kkll,m,isubchap
21010       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
21011       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
21012       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
21013                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
21014                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
21015                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
21016                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
21017                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
21018                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
21019                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
21020       ind=ind+1
21021       itypi=itype(i,2)
21022       itypj=itype(j,2)
21023 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
21024       ael6i=ael6_nucl(itypi,itypj)
21025       ael3i=ael3_nucl(itypi,itypj)
21026       ael63i=ael63_nucl(itypi,itypj)
21027       ael32i=ael32_nucl(itypi,itypj)
21028 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
21029 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
21030       dxj=dc(1,j+nres)
21031       dyj=dc(2,j+nres)
21032       dzj=dc(3,j+nres)
21033       dx_normi=dc_norm(1,i+nres)
21034       dy_normi=dc_norm(2,i+nres)
21035       dz_normi=dc_norm(3,i+nres)
21036       dx_normj=dc_norm(1,j+nres)
21037       dy_normj=dc_norm(2,j+nres)
21038       dz_normj=dc_norm(3,j+nres)
21039 !c      xj=c(1,j)+0.5D0*dxj-xmedi
21040 !c      yj=c(2,j)+0.5D0*dyj-ymedi
21041 !c      zj=c(3,j)+0.5D0*dzj-zmedi
21042       if (ipot_nucl.ne.2) then
21043         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
21044         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
21045         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
21046       else
21047         cosa=om12
21048         cosb=om1
21049         cosg=om2
21050       endif
21051       r3ij=rij*rrij
21052       r6ij=r3ij*r3ij
21053       fac=cosa-3.0D0*cosb*cosg
21054       facfac=fac*fac
21055       fac1=3.0d0*(cosb*cosb+cosg*cosg)
21056       fac3=ael6i*r6ij
21057       fac4=ael3i*r3ij
21058       fac5=ael63i*r6ij
21059       fac6=ael32i*r6ij
21060 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
21061 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
21062       el1=fac3*(4.0D0+facfac-fac1)
21063       el2=fac4*fac
21064       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
21065       el4=fac6*facfac
21066       eesij=el1+el2+el3+el4
21067 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
21068       ees0ij=4.0D0+facfac-fac1
21069
21070       if (energy_dec) then
21071           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
21072           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
21073            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
21074            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
21075            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
21076           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
21077       endif
21078
21079 !C
21080 !C Calculate contributions to the Cartesian gradient.
21081 !C
21082       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
21083       fac1=fac
21084 !c      erij(1)=xj*rmij
21085 !c      erij(2)=yj*rmij
21086 !c      erij(3)=zj*rmij
21087 !*
21088 !* Radial derivatives. First process both termini of the fragment (i,j)
21089 !*
21090       ggg(1)=facel*xj
21091       ggg(2)=facel*yj
21092       ggg(3)=facel*zj
21093       do k=1,3
21094         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21095         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21096         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
21097         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
21098       enddo
21099 !*
21100 !* Angular part
21101 !*
21102       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
21103       fac4=-3.0D0*fac4
21104       fac3=-6.0D0*fac3
21105       fac5= 6.0d0*fac5
21106       fac6=-6.0d0*fac6
21107       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
21108        fac6*fac1*cosg
21109       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
21110        fac6*fac1*cosb
21111       do k=1,3
21112         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
21113         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
21114       enddo
21115       do k=1,3
21116         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
21117       enddo
21118       do k=1,3
21119         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
21120              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
21121              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21122         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
21123              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21124              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21125         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21126         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21127       enddo
21128 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
21129        IF ( j.gt.i+1 .and.&
21130           num_conti.le.maxconts) THEN
21131 !C
21132 !C Calculate the contact function. The ith column of the array JCONT will
21133 !C contain the numbers of atoms that make contacts with the atom I (of numbers
21134 !C greater than I). The arrays FACONT and GACONT will contain the values of
21135 !C the contact function and its derivative.
21136         r0ij=2.20D0*sigma(itypi,itypj)
21137 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
21138         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
21139 !c        write (2,*) "fcont",fcont
21140         if (fcont.gt.0.0D0) then
21141           num_conti=num_conti+1
21142           num_conti2=num_conti2+1
21143
21144           if (num_conti.gt.maxconts) then
21145             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
21146                           ' will skip next contacts for this conf.'
21147           else
21148             jcont_hb(num_conti,i)=j
21149 !c            write (iout,*) "num_conti",num_conti,
21150 !c     &        " jcont_hb",jcont_hb(num_conti,i)
21151 !C Calculate contact energies
21152             cosa4=4.0D0*cosa
21153             wij=cosa-3.0D0*cosb*cosg
21154             cosbg1=cosb+cosg
21155             cosbg2=cosb-cosg
21156             fac3=dsqrt(-ael6i)*r3ij
21157 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
21158             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
21159             if (ees0tmp.gt.0) then
21160               ees0pij=dsqrt(ees0tmp)
21161             else
21162               ees0pij=0
21163             endif
21164             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21165             if (ees0tmp.gt.0) then
21166               ees0mij=dsqrt(ees0tmp)
21167             else
21168               ees0mij=0
21169             endif
21170             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21171             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
21172 !c            write (iout,*) "i",i," j",j,
21173 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21174             ees0pij1=fac3/ees0pij
21175             ees0mij1=fac3/ees0mij
21176             fac3p=-3.0D0*fac3*rrij
21177             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21178             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21179             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21180             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21181             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21182             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21183             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21184             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21185             ecosap=ecosa1+ecosa2
21186             ecosbp=ecosb1+ecosb2
21187             ecosgp=ecosg1+ecosg2
21188             ecosam=ecosa1-ecosa2
21189             ecosbm=ecosb1-ecosb2
21190             ecosgm=ecosg1-ecosg2
21191 !C End diagnostics
21192             facont_hb(num_conti,i)=fcont
21193             fprimcont=fprimcont/rij
21194             do k=1,3
21195               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21196               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21197             enddo
21198             gggp(1)=gggp(1)+ees0pijp*xj
21199             gggp(2)=gggp(2)+ees0pijp*yj
21200             gggp(3)=gggp(3)+ees0pijp*zj
21201             gggm(1)=gggm(1)+ees0mijp*xj
21202             gggm(2)=gggm(2)+ees0mijp*yj
21203             gggm(3)=gggm(3)+ees0mijp*zj
21204 !C Derivatives due to the contact function
21205             gacont_hbr(1,num_conti,i)=fprimcont*xj
21206             gacont_hbr(2,num_conti,i)=fprimcont*yj
21207             gacont_hbr(3,num_conti,i)=fprimcont*zj
21208             do k=1,3
21209 !c
21210 !c Gradient of the correlation terms
21211 !c
21212               gacontp_hb1(k,num_conti,i)= &
21213              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21214             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21215               gacontp_hb2(k,num_conti,i)= &
21216              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21217             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21218               gacontp_hb3(k,num_conti,i)=gggp(k)
21219               gacontm_hb1(k,num_conti,i)= &
21220              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21221             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21222               gacontm_hb2(k,num_conti,i)= &
21223              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21224             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21225               gacontm_hb3(k,num_conti,i)=gggm(k)
21226             enddo
21227           endif
21228         endif
21229       ENDIF
21230       return
21231       end subroutine eelsbij
21232 !------------------------------------------------------------------
21233       subroutine sc_grad_nucl
21234       use comm_locel
21235       use calc_data_nucl
21236       real(kind=8),dimension(3) :: dcosom1,dcosom2
21237       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21238       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21239       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21240       do k=1,3
21241         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21242         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21243       enddo
21244       do k=1,3
21245         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21246       enddo
21247       do k=1,3
21248         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21249                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21250                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21251         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21252                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21253                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21254       enddo
21255 !C
21256 !C Calculate the components of the gradient in DC and X
21257 !C
21258       do l=1,3
21259         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21260         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21261       enddo
21262       return
21263       end subroutine sc_grad_nucl
21264 !-----------------------------------------------------------------------
21265       subroutine esb(esbloc)
21266 !C Calculate the local energy of a side chain and its derivatives in the
21267 !C corresponding virtual-bond valence angles THETA and the spherical angles
21268 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21269 !C added by Urszula Kozlowska. 07/11/2007
21270 !C
21271       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21272       real(kind=8),dimension(9):: x
21273      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21274       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21275       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21276       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21277        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21278        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21279        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21280        integer::it,nlobit,i,j,k
21281 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21282       delta=0.02d0*pi
21283       esbloc=0.0D0
21284       do i=loc_start_nucl,loc_end_nucl
21285         if (itype(i,2).eq.ntyp1_molec(2)) cycle
21286         costtab(i+1) =dcos(theta(i+1))
21287         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21288         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21289         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21290         cosfac2=0.5d0/(1.0d0+costtab(i+1))
21291         cosfac=dsqrt(cosfac2)
21292         sinfac2=0.5d0/(1.0d0-costtab(i+1))
21293         sinfac=dsqrt(sinfac2)
21294         it=itype(i,2)
21295         if (it.eq.10) goto 1
21296
21297 !c
21298 !C  Compute the axes of tghe local cartesian coordinates system; store in
21299 !c   x_prime, y_prime and z_prime
21300 !c
21301         do j=1,3
21302           x_prime(j) = 0.00
21303           y_prime(j) = 0.00
21304           z_prime(j) = 0.00
21305         enddo
21306 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21307 !C     &   dc_norm(3,i+nres)
21308         do j = 1,3
21309           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21310           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21311         enddo
21312         do j = 1,3
21313           z_prime(j) = -uz(j,i-1)
21314 !           z_prime(j)=0.0
21315         enddo
21316
21317         xx=0.0d0
21318         yy=0.0d0
21319         zz=0.0d0
21320         do j = 1,3
21321           xx = xx + x_prime(j)*dc_norm(j,i+nres)
21322           yy = yy + y_prime(j)*dc_norm(j,i+nres)
21323           zz = zz + z_prime(j)*dc_norm(j,i+nres)
21324         enddo
21325
21326         xxtab(i)=xx
21327         yytab(i)=yy
21328         zztab(i)=zz
21329          it=itype(i,2)
21330         do j = 1,9
21331           x(j) = sc_parmin_nucl(j,it)
21332         enddo
21333 #ifdef CHECK_COORD
21334 !Cc diagnostics - remove later
21335         xx1 = dcos(alph(2))
21336         yy1 = dsin(alph(2))*dcos(omeg(2))
21337         zz1 = -dsin(alph(2))*dsin(omeg(2))
21338         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21339          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21340          xx1,yy1,zz1
21341 !C,"  --- ", xx_w,yy_w,zz_w
21342 !c end diagnostics
21343 #endif
21344         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21345         esbloc = esbloc + sumene
21346         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21347 !        print *,"enecomp",sumene,sumene2
21348 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21349 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21350 #ifdef DEBUG
21351         write (2,*) "x",(x(k),k=1,9)
21352 !C
21353 !C This section to check the numerical derivatives of the energy of ith side
21354 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
21355 !C #define DEBUG in the code to turn it on.
21356 !C
21357         write (2,*) "sumene               =",sumene
21358         aincr=1.0d-7
21359         xxsave=xx
21360         xx=xx+aincr
21361         write (2,*) xx,yy,zz
21362         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21363         de_dxx_num=(sumenep-sumene)/aincr
21364         xx=xxsave
21365         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
21366         yysave=yy
21367         yy=yy+aincr
21368         write (2,*) xx,yy,zz
21369         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21370         de_dyy_num=(sumenep-sumene)/aincr
21371         yy=yysave
21372         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
21373         zzsave=zz
21374         zz=zz+aincr
21375         write (2,*) xx,yy,zz
21376         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21377         de_dzz_num=(sumenep-sumene)/aincr
21378         zz=zzsave
21379         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
21380         costsave=cost2tab(i+1)
21381         sintsave=sint2tab(i+1)
21382         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
21383         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
21384         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21385         de_dt_num=(sumenep-sumene)/aincr
21386         write (2,*) " t+ sumene from enesc=",sumenep,sumene
21387         cost2tab(i+1)=costsave
21388         sint2tab(i+1)=sintsave
21389 !C End of diagnostics section.
21390 #endif
21391 !C
21392 !C Compute the gradient of esc
21393 !C
21394         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
21395         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
21396         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
21397         de_dtt=0.0d0
21398 #ifdef DEBUG
21399         write (2,*) "x",(x(k),k=1,9)
21400         write (2,*) "xx",xx," yy",yy," zz",zz
21401         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
21402           " de_zz   ",de_zz," de_tt   ",de_tt
21403         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
21404           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
21405 #endif
21406 !C
21407        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
21408        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
21409        cosfac2xx=cosfac2*xx
21410        sinfac2yy=sinfac2*yy
21411        do k = 1,3
21412          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
21413            vbld_inv(i+1)
21414          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
21415            vbld_inv(i)
21416          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
21417          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
21418 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
21419 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
21420 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
21421 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
21422          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
21423          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
21424          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
21425          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
21426          dZZ_Ci1(k)=0.0d0
21427          dZZ_Ci(k)=0.0d0
21428          do j=1,3
21429            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
21430            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
21431          enddo
21432
21433          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
21434          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
21435          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
21436 !c
21437          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
21438          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
21439        enddo
21440
21441        do k=1,3
21442          dXX_Ctab(k,i)=dXX_Ci(k)
21443          dXX_C1tab(k,i)=dXX_Ci1(k)
21444          dYY_Ctab(k,i)=dYY_Ci(k)
21445          dYY_C1tab(k,i)=dYY_Ci1(k)
21446          dZZ_Ctab(k,i)=dZZ_Ci(k)
21447          dZZ_C1tab(k,i)=dZZ_Ci1(k)
21448          dXX_XYZtab(k,i)=dXX_XYZ(k)
21449          dYY_XYZtab(k,i)=dYY_XYZ(k)
21450          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
21451        enddo
21452        do k = 1,3
21453 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
21454 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
21455 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
21456 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
21457 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
21458 !c     &    dt_dci(k)
21459 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
21460 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
21461          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
21462          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
21463          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
21464          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
21465          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
21466          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
21467 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
21468        enddo
21469 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
21470 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
21471
21472 !C to check gradient call subroutine check_grad
21473
21474     1 continue
21475       enddo
21476       return
21477       end subroutine esb
21478 !=-------------------------------------------------------
21479       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
21480 !      implicit none
21481       real(kind=8),dimension(9):: x(9)
21482        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
21483       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
21484       integer i
21485 !c      write (2,*) "enesc"
21486 !c      write (2,*) "x",(x(i),i=1,9)
21487 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
21488       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
21489         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
21490         + x(9)*yy*zz
21491       enesc_nucl=sumene
21492       return
21493       end function enesc_nucl
21494 !-----------------------------------------------------------------------------
21495       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
21496 #ifdef MPI
21497       include 'mpif.h'
21498       integer,parameter :: max_cont=2000
21499       integer,parameter:: max_dim=2*(8*3+6)
21500       integer, parameter :: msglen1=max_cont*max_dim
21501       integer,parameter :: msglen2=2*msglen1
21502       integer source,CorrelType,CorrelID,Error
21503       real(kind=8) :: buffer(max_cont,max_dim)
21504       integer status(MPI_STATUS_SIZE)
21505       integer :: ierror,nbytes
21506 #endif
21507       real(kind=8),dimension(3):: gx(3),gx1(3)
21508       real(kind=8) :: time00
21509       logical lprn,ldone
21510       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
21511       real(kind=8) ecorr,ecorr3
21512       integer :: n_corr,n_corr1,mm,msglen
21513 !C Set lprn=.true. for debugging
21514       lprn=.false.
21515       n_corr=0
21516       n_corr1=0
21517 #ifdef MPI
21518       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
21519
21520       if (nfgtasks.le.1) goto 30
21521       if (lprn) then
21522         write (iout,'(a)') 'Contact function values:'
21523         do i=nnt,nct-1
21524           write (iout,'(2i3,50(1x,i2,f5.2))')  &
21525          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21526          j=1,num_cont_hb(i))
21527         enddo
21528       endif
21529 !C Caution! Following code assumes that electrostatic interactions concerning
21530 !C a given atom are split among at most two processors!
21531       CorrelType=477
21532       CorrelID=fg_rank+1
21533       ldone=.false.
21534       do i=1,max_cont
21535         do j=1,max_dim
21536           buffer(i,j)=0.0D0
21537         enddo
21538       enddo
21539       mm=mod(fg_rank,2)
21540 !c      write (*,*) 'MyRank',MyRank,' mm',mm
21541       if (mm) 20,20,10
21542    10 continue
21543 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
21544       if (fg_rank.gt.0) then
21545 !C Send correlation contributions to the preceding processor
21546         msglen=msglen1
21547         nn=num_cont_hb(iatel_s_nucl)
21548         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
21549 !c        write (*,*) 'The BUFFER array:'
21550 !c        do i=1,nn
21551 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
21552 !c        enddo
21553         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
21554           msglen=msglen2
21555           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
21556 !C Clear the contacts of the atom passed to the neighboring processor
21557         nn=num_cont_hb(iatel_s_nucl+1)
21558 !c        do i=1,nn
21559 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
21560 !c        enddo
21561             num_cont_hb(iatel_s_nucl)=0
21562         endif
21563 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
21564 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
21565 !cd   & ' msglen=',msglen
21566 !c        write (*,*) 'Processor ',fg_rank,MyRank,
21567 !c     & ' is sending correlation contribution to processor',fg_rank-1,
21568 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21569         time00=MPI_Wtime()
21570         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
21571          CorrelType,FG_COMM,IERROR)
21572         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21573 !cd      write (iout,*) 'Processor ',fg_rank,
21574 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
21575 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
21576 !c        write (*,*) 'Processor ',fg_rank,
21577 !c     & ' has sent correlation contribution to processor',fg_rank-1,
21578 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
21579 !c        msglen=msglen1
21580       endif ! (fg_rank.gt.0)
21581       if (ldone) goto 30
21582       ldone=.true.
21583    20 continue
21584 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
21585       if (fg_rank.lt.nfgtasks-1) then
21586 !C Receive correlation contributions from the next processor
21587         msglen=msglen1
21588         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
21589 !cd      write (iout,*) 'Processor',fg_rank,
21590 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
21591 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
21592 !c        write (*,*) 'Processor',fg_rank,
21593 !c     &' is receiving correlation contribution from processor',fg_rank+1,
21594 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21595         time00=MPI_Wtime()
21596         nbytes=-1
21597         do while (nbytes.le.0)
21598           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21599           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
21600         enddo
21601 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
21602         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
21603          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21604         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21605 !c        write (*,*) 'Processor',fg_rank,
21606 !c     &' has received correlation contribution from processor',fg_rank+1,
21607 !c     & ' msglen=',msglen,' nbytes=',nbytes
21608 !c        write (*,*) 'The received BUFFER array:'
21609 !c        do i=1,max_cont
21610 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
21611 !c        enddo
21612         if (msglen.eq.msglen1) then
21613           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
21614         else if (msglen.eq.msglen2)  then
21615           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
21616           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
21617         else
21618           write (iout,*) &
21619       'ERROR!!!! message length changed while processing correlations.'
21620           write (*,*) &
21621       'ERROR!!!! message length changed while processing correlations.'
21622           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
21623         endif ! msglen.eq.msglen1
21624       endif ! fg_rank.lt.nfgtasks-1
21625       if (ldone) goto 30
21626       ldone=.true.
21627       goto 10
21628    30 continue
21629 #endif
21630       if (lprn) then
21631         write (iout,'(a)') 'Contact function values:'
21632         do i=nnt_molec(2),nct_molec(2)-1
21633           write (iout,'(2i3,50(1x,i2,f5.2))') &
21634          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21635          j=1,num_cont_hb(i))
21636         enddo
21637       endif
21638       ecorr=0.0D0
21639       ecorr3=0.0d0
21640 !C Remove the loop below after debugging !!!
21641 !      do i=nnt_molec(2),nct_molec(2)
21642 !        do j=1,3
21643 !          gradcorr_nucl(j,i)=0.0D0
21644 !          gradxorr_nucl(j,i)=0.0D0
21645 !          gradcorr3_nucl(j,i)=0.0D0
21646 !          gradxorr3_nucl(j,i)=0.0D0
21647 !        enddo
21648 !      enddo
21649 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
21650 !C Calculate the local-electrostatic correlation terms
21651       do i=iatsc_s_nucl,iatsc_e_nucl
21652         i1=i+1
21653         num_conti=num_cont_hb(i)
21654         num_conti1=num_cont_hb(i+1)
21655 !        print *,i,num_conti,num_conti1
21656         do jj=1,num_conti
21657           j=jcont_hb(jj,i)
21658           do kk=1,num_conti1
21659             j1=jcont_hb(kk,i1)
21660 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
21661 !c     &         ' jj=',jj,' kk=',kk
21662             if (j1.eq.j+1 .or. j1.eq.j-1) then
21663 !C
21664 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
21665 !C The system gains extra energy.
21666 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
21667 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21668 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
21669 !C
21670               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21671               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
21672                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21673               n_corr=n_corr+1
21674             else if (j1.eq.j) then
21675 !C
21676 !C Contacts I-J and I-(J+1) occur simultaneously.
21677 !C The system loses extra energy.
21678 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
21679 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21680 !C Need to implement full formulas 32 from Liwo et al., 1998.
21681 !C
21682 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21683 !c     &         ' jj=',jj,' kk=',kk
21684               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
21685             endif
21686           enddo ! kk
21687           do kk=1,num_conti
21688             j1=jcont_hb(kk,i)
21689 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21690 !c     &         ' jj=',jj,' kk=',kk
21691             if (j1.eq.j+1) then
21692 !C Contacts I-J and (I+1)-J occur simultaneously.
21693 !C The system loses extra energy.
21694               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
21695             endif ! j1==j+1
21696           enddo ! kk
21697         enddo ! jj
21698       enddo ! i
21699       return
21700       end subroutine multibody_hb_nucl
21701 !-----------------------------------------------------------
21702       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21703 !      implicit real*8 (a-h,o-z)
21704 !      include 'DIMENSIONS'
21705 !      include 'COMMON.IOUNITS'
21706 !      include 'COMMON.DERIV'
21707 !      include 'COMMON.INTERACT'
21708 !      include 'COMMON.CONTACTS'
21709       real(kind=8),dimension(3) :: gx,gx1
21710       logical :: lprn
21711 !el local variables
21712       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21713       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21714                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21715                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21716                    rlocshield
21717
21718       lprn=.false.
21719       eij=facont_hb(jj,i)
21720       ekl=facont_hb(kk,k)
21721       ees0pij=ees0p(jj,i)
21722       ees0pkl=ees0p(kk,k)
21723       ees0mij=ees0m(jj,i)
21724       ees0mkl=ees0m(kk,k)
21725       ekont=eij*ekl
21726       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21727 !      print *,"ehbcorr_nucl",ekont,ees
21728 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21729 !C Following 4 lines for diagnostics.
21730 !cd    ees0pkl=0.0D0
21731 !cd    ees0pij=1.0D0
21732 !cd    ees0mkl=0.0D0
21733 !cd    ees0mij=1.0D0
21734 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21735 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21736 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21737 !C Calculate the multi-body contribution to energy.
21738 !      ecorr_nucl=ecorr_nucl+ekont*ees
21739 !C Calculate multi-body contributions to the gradient.
21740       coeffpees0pij=coeffp*ees0pij
21741       coeffmees0mij=coeffm*ees0mij
21742       coeffpees0pkl=coeffp*ees0pkl
21743       coeffmees0mkl=coeffm*ees0mkl
21744       do ll=1,3
21745         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
21746        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21747        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21748         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
21749         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
21750         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21751         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
21752         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
21753         coeffmees0mij*gacontm_hb1(ll,kk,k))
21754         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
21755         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21756         coeffmees0mij*gacontm_hb2(ll,kk,k))
21757         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21758           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21759           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21760         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
21761         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
21762         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21763           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21764           coeffmees0mij*gacontm_hb3(ll,kk,k))
21765         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
21766         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
21767         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
21768         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
21769         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
21770         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
21771       enddo
21772       ehbcorr_nucl=ekont*ees
21773       return
21774       end function ehbcorr_nucl
21775 !-------------------------------------------------------------------------
21776
21777      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21778 !      implicit real*8 (a-h,o-z)
21779 !      include 'DIMENSIONS'
21780 !      include 'COMMON.IOUNITS'
21781 !      include 'COMMON.DERIV'
21782 !      include 'COMMON.INTERACT'
21783 !      include 'COMMON.CONTACTS'
21784       real(kind=8),dimension(3) :: gx,gx1
21785       logical :: lprn
21786 !el local variables
21787       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21788       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21789                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21790                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21791                    rlocshield
21792
21793       lprn=.false.
21794       eij=facont_hb(jj,i)
21795       ekl=facont_hb(kk,k)
21796       ees0pij=ees0p(jj,i)
21797       ees0pkl=ees0p(kk,k)
21798       ees0mij=ees0m(jj,i)
21799       ees0mkl=ees0m(kk,k)
21800       ekont=eij*ekl
21801       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21802 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21803 !C Following 4 lines for diagnostics.
21804 !cd    ees0pkl=0.0D0
21805 !cd    ees0pij=1.0D0
21806 !cd    ees0mkl=0.0D0
21807 !cd    ees0mij=1.0D0
21808 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21809 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21810 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21811 !C Calculate the multi-body contribution to energy.
21812 !      ecorr=ecorr+ekont*ees
21813 !C Calculate multi-body contributions to the gradient.
21814       coeffpees0pij=coeffp*ees0pij
21815       coeffmees0mij=coeffm*ees0mij
21816       coeffpees0pkl=coeffp*ees0pkl
21817       coeffmees0mkl=coeffm*ees0mkl
21818       do ll=1,3
21819         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
21820        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21821        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21822         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
21823         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
21824         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21825         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
21826         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
21827         coeffmees0mij*gacontm_hb1(ll,kk,k))
21828         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
21829         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21830         coeffmees0mij*gacontm_hb2(ll,kk,k))
21831         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21832           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21833           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21834         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
21835         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
21836         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21837           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21838           coeffmees0mij*gacontm_hb3(ll,kk,k))
21839         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
21840         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
21841         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
21842         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
21843         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
21844         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
21845       enddo
21846       ehbcorr3_nucl=ekont*ees
21847       return
21848       end function ehbcorr3_nucl
21849 #ifdef MPI
21850       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
21851       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21852       real(kind=8):: buffer(dimen1,dimen2)
21853       num_kont=num_cont_hb(atom)
21854       do i=1,num_kont
21855         do k=1,8
21856           do j=1,3
21857             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
21858           enddo ! j
21859         enddo ! k
21860         buffer(i,indx+25)=facont_hb(i,atom)
21861         buffer(i,indx+26)=ees0p(i,atom)
21862         buffer(i,indx+27)=ees0m(i,atom)
21863         buffer(i,indx+28)=d_cont(i,atom)
21864         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
21865       enddo ! i
21866       buffer(1,indx+30)=dfloat(num_kont)
21867       return
21868       end subroutine pack_buffer
21869 !c------------------------------------------------------------------------------
21870       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
21871       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21872       real(kind=8):: buffer(dimen1,dimen2)
21873 !      double precision zapas
21874 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
21875 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
21876 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
21877 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
21878       num_kont=buffer(1,indx+30)
21879       num_kont_old=num_cont_hb(atom)
21880       num_cont_hb(atom)=num_kont+num_kont_old
21881       do i=1,num_kont
21882         ii=i+num_kont_old
21883         do k=1,8
21884           do j=1,3
21885             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
21886           enddo ! j
21887         enddo ! k
21888         facont_hb(ii,atom)=buffer(i,indx+25)
21889         ees0p(ii,atom)=buffer(i,indx+26)
21890         ees0m(ii,atom)=buffer(i,indx+27)
21891         d_cont(i,atom)=buffer(i,indx+28)
21892         jcont_hb(ii,atom)=buffer(i,indx+29)
21893       enddo ! i
21894       return
21895       end subroutine unpack_buffer
21896 !c------------------------------------------------------------------------------
21897 #endif
21898       subroutine ecatcat(ecationcation)
21899         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k
21900         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21901         r7,r4,ecationcation,k0,rcal
21902         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21903         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
21904         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21905         gg,r
21906
21907         ecationcation=0.0d0
21908         if (nres_molec(5).eq.0) return
21909         rcat0=3.472
21910         epscalc=0.05
21911         r06 = rcat0**6
21912         r012 = r06**2
21913         k0 = 332.0*(2.0*2.0)/80.0
21914         itmp=0
21915
21916         do i=1,4
21917         itmp=itmp+nres_molec(i)
21918         enddo
21919 !        write(iout,*) "itmp",itmp
21920         do i=itmp+1,itmp+nres_molec(5)-1
21921
21922         xi=c(1,i)
21923         yi=c(2,i)
21924         zi=c(3,i)
21925
21926           xi=mod(xi,boxxsize)
21927           if (xi.lt.0) xi=xi+boxxsize
21928           yi=mod(yi,boxysize)
21929           if (yi.lt.0) yi=yi+boxysize
21930           zi=mod(zi,boxzsize)
21931           if (zi.lt.0) zi=zi+boxzsize
21932
21933           do j=i+1,itmp+nres_molec(5)
21934 !           print *,i,j,'catcat'
21935            xj=c(1,j)
21936            yj=c(2,j)
21937            zj=c(3,j)
21938           xj=dmod(xj,boxxsize)
21939           if (xj.lt.0) xj=xj+boxxsize
21940           yj=dmod(yj,boxysize)
21941           if (yj.lt.0) yj=yj+boxysize
21942           zj=dmod(zj,boxzsize)
21943           if (zj.lt.0) zj=zj+boxzsize
21944 !          write(iout,*) c(1,i),xi,xj,"xy",boxxsize
21945       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21946       xj_safe=xj
21947       yj_safe=yj
21948       zj_safe=zj
21949       subchap=0
21950       do xshift=-1,1
21951       do yshift=-1,1
21952       do zshift=-1,1
21953           xj=xj_safe+xshift*boxxsize
21954           yj=yj_safe+yshift*boxysize
21955           zj=zj_safe+zshift*boxzsize
21956           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21957           if(dist_temp.lt.dist_init) then
21958             dist_init=dist_temp
21959             xj_temp=xj
21960             yj_temp=yj
21961             zj_temp=zj
21962             subchap=1
21963           endif
21964        enddo
21965        enddo
21966        enddo
21967        if (subchap.eq.1) then
21968           xj=xj_temp-xi
21969           yj=yj_temp-yi
21970           zj=zj_temp-zi
21971        else
21972           xj=xj_safe-xi
21973           yj=yj_safe-yi
21974           zj=zj_safe-zi
21975        endif
21976        rcal =xj**2+yj**2+zj**2
21977         ract=sqrt(rcal)
21978 !        rcat0=3.472
21979 !        epscalc=0.05
21980 !        r06 = rcat0**6
21981 !        r012 = r06**2
21982 !        k0 = 332*(2*2)/80
21983         Evan1cat=epscalc*(r012/rcal**6)
21984         Evan2cat=epscalc*2*(r06/rcal**3)
21985         Eeleccat=k0/ract
21986         r7 = rcal**7
21987         r4 = rcal**4
21988         r(1)=xj
21989         r(2)=yj
21990         r(3)=zj
21991         do k=1,3
21992           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
21993           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
21994           dEeleccat(k)=-k0*r(k)/ract**3
21995         enddo
21996         do k=1,3
21997           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
21998           gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
21999           gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
22000         enddo
22001
22002 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
22003         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
22004        enddo
22005        enddo
22006        return
22007        end subroutine ecatcat
22008 !---------------------------------------------------------------------------
22009        subroutine ecat_prot(ecation_prot)
22010        integer i,j,k,subchap,itmp,inum
22011         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22012         r7,r4,ecationcation
22013         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22014         dist_init,dist_temp,ecation_prot,rcal,rocal,   &
22015         Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
22016         catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
22017         wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
22018         costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
22019         Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
22020         rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
22021         opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
22022         opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
22023         Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip
22024         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22025         gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
22026         dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
22027         tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
22028         v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
22029         dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
22030         dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
22031         dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
22032         dEvan1Cat
22033         real(kind=8),dimension(6) :: vcatprm
22034         ecation_prot=0.0d0
22035 ! first lets calculate interaction with peptide groups
22036         if (nres_molec(5).eq.0) return
22037          wconst=78
22038         wdip =1.092777950857032D2
22039         wdip=wdip/wconst
22040         wmodquad=-2.174122713004870D4
22041         wmodquad=wmodquad/wconst
22042         wquad1 = 3.901232068562804D1
22043         wquad1=wquad1/wconst
22044         wquad2 = 3
22045         wquad2=wquad2/wconst
22046         wvan1 = 0.1
22047         wvan2 = 6
22048         itmp=0
22049         do i=1,4
22050         itmp=itmp+nres_molec(i)
22051         enddo
22052 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22053         do i=ibond_start,ibond_end
22054 !         cycle
22055          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
22056         xi=0.5d0*(c(1,i)+c(1,i+1))
22057         yi=0.5d0*(c(2,i)+c(2,i+1))
22058         zi=0.5d0*(c(3,i)+c(3,i+1))
22059           xi=mod(xi,boxxsize)
22060           if (xi.lt.0) xi=xi+boxxsize
22061           yi=mod(yi,boxysize)
22062           if (yi.lt.0) yi=yi+boxysize
22063           zi=mod(zi,boxzsize)
22064           if (zi.lt.0) zi=zi+boxzsize
22065
22066          do j=itmp+1,itmp+nres_molec(5)
22067            xj=c(1,j)
22068            yj=c(2,j)
22069            zj=c(3,j)
22070           xj=dmod(xj,boxxsize)
22071           if (xj.lt.0) xj=xj+boxxsize
22072           yj=dmod(yj,boxysize)
22073           if (yj.lt.0) yj=yj+boxysize
22074           zj=dmod(zj,boxzsize)
22075           if (zj.lt.0) zj=zj+boxzsize
22076       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22077       xj_safe=xj
22078       yj_safe=yj
22079       zj_safe=zj
22080       subchap=0
22081       do xshift=-1,1
22082       do yshift=-1,1
22083       do zshift=-1,1
22084           xj=xj_safe+xshift*boxxsize
22085           yj=yj_safe+yshift*boxysize
22086           zj=zj_safe+zshift*boxzsize
22087           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22088           if(dist_temp.lt.dist_init) then
22089             dist_init=dist_temp
22090             xj_temp=xj
22091             yj_temp=yj
22092             zj_temp=zj
22093             subchap=1
22094           endif
22095        enddo
22096        enddo
22097        enddo
22098        if (subchap.eq.1) then
22099           xj=xj_temp-xi
22100           yj=yj_temp-yi
22101           zj=zj_temp-zi
22102        else
22103           xj=xj_safe-xi
22104           yj=yj_safe-yi
22105           zj=zj_safe-zi
22106        endif
22107 !       enddo
22108 !       enddo
22109        rcpm = sqrt(xj**2+yj**2+zj**2)
22110        drcp_norm(1)=xj/rcpm
22111        drcp_norm(2)=yj/rcpm
22112        drcp_norm(3)=zj/rcpm
22113        dcmag=0.0
22114        do k=1,3
22115        dcmag=dcmag+dc(k,i)**2
22116        enddo
22117        dcmag=dsqrt(dcmag)
22118        do k=1,3
22119          myd_norm(k)=dc(k,i)/dcmag
22120        enddo
22121         costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
22122         drcp_norm(3)*myd_norm(3)
22123         rsecp = rcpm**2
22124         Ir = 1.0d0/rcpm
22125         Irsecp = 1.0d0/rsecp
22126         Irthrp = Irsecp/rcpm
22127         Irfourp = Irthrp/rcpm
22128         Irfiftp = Irfourp/rcpm
22129         Irsistp=Irfiftp/rcpm
22130         Irseven=Irsistp/rcpm
22131         Irtwelv=Irsistp*Irsistp
22132         Irthir=Irtwelv/rcpm
22133         sin2thet = (1-costhet*costhet)
22134         sinthet=sqrt(sin2thet)
22135         E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
22136              *sin2thet
22137         E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
22138              2*wvan2**6*Irsistp)
22139         ecation_prot = ecation_prot+E1+E2
22140         dE1dr = -2*costhet*wdip*Irthrp-&
22141          (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
22142         dE2dr = 3*wquad1*wquad2*Irfourp-     &
22143           12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
22144         dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
22145         do k=1,3
22146           drdpep(k) = -drcp_norm(k)
22147           dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
22148           dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
22149           dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
22150           dEddci(k) = dEdcos*dcosddci(k)
22151         enddo
22152         do k=1,3
22153         gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
22154         gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
22155         gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
22156         enddo
22157        enddo ! j
22158        enddo ! i
22159 !------------------------------------------sidechains
22160 !        do i=1,nres_molec(1)
22161         do i=ibond_start,ibond_end
22162          if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
22163 !         cycle
22164 !        print *,i,ecation_prot
22165         xi=(c(1,i+nres))
22166         yi=(c(2,i+nres))
22167         zi=(c(3,i+nres))
22168           xi=mod(xi,boxxsize)
22169           if (xi.lt.0) xi=xi+boxxsize
22170           yi=mod(yi,boxysize)
22171           if (yi.lt.0) yi=yi+boxysize
22172           zi=mod(zi,boxzsize)
22173           if (zi.lt.0) zi=zi+boxzsize
22174           do k=1,3
22175             cm1(k)=dc(k,i+nres)
22176           enddo
22177            cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
22178          do j=itmp+1,itmp+nres_molec(5)
22179            xj=c(1,j)
22180            yj=c(2,j)
22181            zj=c(3,j)
22182           xj=dmod(xj,boxxsize)
22183           if (xj.lt.0) xj=xj+boxxsize
22184           yj=dmod(yj,boxysize)
22185           if (yj.lt.0) yj=yj+boxysize
22186           zj=dmod(zj,boxzsize)
22187           if (zj.lt.0) zj=zj+boxzsize
22188       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22189       xj_safe=xj
22190       yj_safe=yj
22191       zj_safe=zj
22192       subchap=0
22193       do xshift=-1,1
22194       do yshift=-1,1
22195       do zshift=-1,1
22196           xj=xj_safe+xshift*boxxsize
22197           yj=yj_safe+yshift*boxysize
22198           zj=zj_safe+zshift*boxzsize
22199           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22200           if(dist_temp.lt.dist_init) then
22201             dist_init=dist_temp
22202             xj_temp=xj
22203             yj_temp=yj
22204             zj_temp=zj
22205             subchap=1
22206           endif
22207        enddo
22208        enddo
22209        enddo
22210        if (subchap.eq.1) then
22211           xj=xj_temp-xi
22212           yj=yj_temp-yi
22213           zj=zj_temp-zi
22214        else
22215           xj=xj_safe-xi
22216           yj=yj_safe-yi
22217           zj=zj_safe-zi
22218        endif
22219 !       enddo
22220 !       enddo
22221          if(itype(i,1).eq.15.or.itype(i,1).eq.16) then
22222             if(itype(i,1).eq.16) then
22223             inum=1
22224             else
22225             inum=2
22226             endif
22227             do k=1,6
22228             vcatprm(k)=catprm(k,inum)
22229             enddo
22230             dASGL=catprm(7,inum)
22231              do k=1,3
22232                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22233                 valpha(k)=c(k,i)
22234                 vcat(k)=c(k,j)
22235               enddo
22236                       do k=1,3
22237           dx(k) = vcat(k)-vcm(k)
22238         enddo
22239         do k=1,3
22240           v1(k)=(vcm(k)-valpha(k))
22241           v2(k)=(vcat(k)-valpha(k))
22242         enddo
22243         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22244         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22245         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22246
22247 !  The weights of the energy function calculated from
22248 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
22249         wh2o=78
22250         wc = vcatprm(1)
22251         wc=wc/wh2o
22252         wdip =vcatprm(2)
22253         wdip=wdip/wh2o
22254         wquad1 =vcatprm(3)
22255         wquad1=wquad1/wh2o
22256         wquad2 = vcatprm(4)
22257         wquad2=wquad2/wh2o
22258         wquad2p = 1-wquad2
22259         wvan1 = vcatprm(5)
22260         wvan2 =vcatprm(6)
22261         opt = dx(1)**2+dx(2)**2
22262         rsecp = opt+dx(3)**2
22263         rs = sqrt(rsecp)
22264         rthrp = rsecp*rs
22265         rfourp = rthrp*rs
22266         rsixp = rfourp*rsecp
22267         reight=rsixp*rsecp
22268         Ir = 1.0d0/rs
22269         Irsecp = 1/rsecp
22270         Irthrp = Irsecp/rs
22271         Irfourp = Irthrp/rs
22272         Irsixp = 1/rsixp
22273         Ireight=1/reight
22274         Irtw=Irsixp*Irsixp
22275         Irthir=Irtw/rs
22276         Irfourt=Irthir/rs
22277         opt1 = (4*rs*dx(3)*wdip)
22278         opt2 = 6*rsecp*wquad1*opt
22279         opt3 = wquad1*wquad2p*Irsixp
22280         opt4 = (wvan1*wvan2**12)
22281         opt5 = opt4*12*Irfourt
22282         opt6 = 2*wvan1*wvan2**6
22283         opt7 = 6*opt6*Ireight
22284         opt8 = wdip/v1m
22285         opt10 = wdip/v2m
22286         opt11 = (rsecp*v2m)**2
22287         opt12 = (rsecp*v1m)**2
22288         opt14 = (v1m*v2m*rsecp)**2
22289         opt15 = -wquad1/v2m**2
22290         opt16 = (rthrp*(v1m*v2m)**2)**2
22291         opt17 = (v1m**2*rthrp)**2
22292         opt18 = -wquad1/rthrp
22293         opt19 = (v1m**2*v2m**2)**2
22294         Ec = wc*Ir
22295         do k=1,3
22296           dEcCat(k) = -(dx(k)*wc)*Irthrp
22297           dEcCm(k)=(dx(k)*wc)*Irthrp
22298           dEcCalp(k)=0.0d0
22299         enddo
22300         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22301         do k=1,3
22302           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
22303                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22304           dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
22305                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22306           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
22307                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
22308                       *v1dpv2)/opt14
22309         enddo
22310         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22311         do k=1,3
22312           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
22313                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
22314                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22315           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
22316                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
22317                       v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22318           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22319                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
22320                         v1dpv2**2)/opt19
22321         enddo
22322         Equad2=wquad1*wquad2p*Irthrp
22323         do k=1,3
22324           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22325           dEquad2Cm(k)=3*dx(k)*rs*opt3
22326           dEquad2Calp(k)=0.0d0
22327         enddo
22328         Evan1=opt4*Irtw
22329         do k=1,3
22330           dEvan1Cat(k)=-dx(k)*opt5
22331           dEvan1Cm(k)=dx(k)*opt5
22332           dEvan1Calp(k)=0.0d0
22333         enddo
22334         Evan2=-opt6*Irsixp
22335         do k=1,3
22336           dEvan2Cat(k)=dx(k)*opt7
22337           dEvan2Cm(k)=-dx(k)*opt7
22338           dEvan2Calp(k)=0.0d0
22339         enddo
22340         ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
22341 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
22342
22343         do k=1,3
22344           dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
22345                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22346 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
22347           dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
22348                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22349           dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
22350                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22351         enddo
22352             dscmag = 0.0d0
22353             do k=1,3
22354               dscvec(k) = dc(k,i+nres)
22355               dscmag = dscmag+dscvec(k)*dscvec(k)
22356             enddo
22357             dscmag3 = dscmag
22358             dscmag = sqrt(dscmag)
22359             dscmag3 = dscmag3*dscmag
22360             constA = 1.0d0+dASGL/dscmag
22361             constB = 0.0d0
22362             do k=1,3
22363               constB = constB+dscvec(k)*dEtotalCm(k)
22364             enddo
22365             constB = constB*dASGL/dscmag3
22366             do k=1,3
22367               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22368               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22369                constA*dEtotalCm(k)-constB*dscvec(k)
22370 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
22371               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22372               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22373              enddo
22374         else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
22375            if(itype(i,1).eq.14) then
22376             inum=3
22377             else
22378             inum=4
22379             endif
22380             do k=1,6
22381             vcatprm(k)=catprm(k,inum)
22382             enddo
22383             dASGL=catprm(7,inum)
22384              do k=1,3
22385                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22386                 valpha(k)=c(k,i)
22387                 vcat(k)=c(k,j)
22388               enddo
22389
22390         do k=1,3
22391           dx(k) = vcat(k)-vcm(k)
22392         enddo
22393         do k=1,3
22394           v1(k)=(vcm(k)-valpha(k))
22395           v2(k)=(vcat(k)-valpha(k))
22396         enddo
22397         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22398         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22399         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22400 !  The weights of the energy function calculated from
22401 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
22402         wh2o=78
22403         wdip =vcatprm(2)
22404         wdip=wdip/wh2o
22405         wquad1 =vcatprm(3)
22406         wquad1=wquad1/wh2o
22407         wquad2 = vcatprm(4)
22408         wquad2=wquad2/wh2o
22409         wquad2p = 1-wquad2
22410         wvan1 = vcatprm(5)
22411         wvan2 =vcatprm(6)
22412         opt = dx(1)**2+dx(2)**2
22413         rsecp = opt+dx(3)**2
22414         rs = sqrt(rsecp)
22415         rthrp = rsecp*rs
22416         rfourp = rthrp*rs
22417         rsixp = rfourp*rsecp
22418         reight=rsixp*rsecp
22419         Ir = 1.0d0/rs
22420         Irsecp = 1/rsecp
22421         Irthrp = Irsecp/rs
22422         Irfourp = Irthrp/rs
22423         Irsixp = 1/rsixp
22424         Ireight=1/reight
22425         Irtw=Irsixp*Irsixp
22426         Irthir=Irtw/rs
22427         Irfourt=Irthir/rs
22428         opt1 = (4*rs*dx(3)*wdip)
22429         opt2 = 6*rsecp*wquad1*opt
22430         opt3 = wquad1*wquad2p*Irsixp
22431         opt4 = (wvan1*wvan2**12)
22432         opt5 = opt4*12*Irfourt
22433         opt6 = 2*wvan1*wvan2**6
22434         opt7 = 6*opt6*Ireight
22435         opt8 = wdip/v1m
22436         opt10 = wdip/v2m
22437         opt11 = (rsecp*v2m)**2
22438         opt12 = (rsecp*v1m)**2
22439         opt14 = (v1m*v2m*rsecp)**2
22440         opt15 = -wquad1/v2m**2
22441         opt16 = (rthrp*(v1m*v2m)**2)**2
22442         opt17 = (v1m**2*rthrp)**2
22443         opt18 = -wquad1/rthrp
22444         opt19 = (v1m**2*v2m**2)**2
22445         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22446         do k=1,3
22447           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
22448                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22449          dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
22450                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22451           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
22452                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
22453                       *v1dpv2)/opt14
22454         enddo
22455         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22456         do k=1,3
22457           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
22458                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
22459                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22460           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
22461                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
22462                        v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22463           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22464                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
22465                         v1dpv2**2)/opt19
22466         enddo
22467         Equad2=wquad1*wquad2p*Irthrp
22468         do k=1,3
22469           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22470           dEquad2Cm(k)=3*dx(k)*rs*opt3
22471           dEquad2Calp(k)=0.0d0
22472         enddo
22473         Evan1=opt4*Irtw
22474         do k=1,3
22475           dEvan1Cat(k)=-dx(k)*opt5
22476           dEvan1Cm(k)=dx(k)*opt5
22477           dEvan1Calp(k)=0.0d0
22478         enddo
22479         Evan2=-opt6*Irsixp
22480         do k=1,3
22481           dEvan2Cat(k)=dx(k)*opt7
22482           dEvan2Cm(k)=-dx(k)*opt7
22483           dEvan2Calp(k)=0.0d0
22484         enddo
22485          ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
22486         do k=1,3
22487           dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
22488                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22489           dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
22490                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22491           dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
22492                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22493         enddo
22494             dscmag = 0.0d0
22495             do k=1,3
22496               dscvec(k) = c(k,i+nres)-c(k,i)
22497               dscmag = dscmag+dscvec(k)*dscvec(k)
22498             enddo
22499             dscmag3 = dscmag
22500             dscmag = sqrt(dscmag)
22501             dscmag3 = dscmag3*dscmag
22502             constA = 1+dASGL/dscmag
22503             constB = 0.0d0
22504             do k=1,3
22505               constB = constB+dscvec(k)*dEtotalCm(k)
22506             enddo
22507             constB = constB*dASGL/dscmag3
22508             do k=1,3
22509               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22510               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22511                constA*dEtotalCm(k)-constB*dscvec(k)
22512               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22513               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22514              enddo
22515            else
22516             rcal = 0.0d0
22517             do k=1,3
22518               r(k) = c(k,j)-c(k,i+nres)
22519               rcal = rcal+r(k)*r(k)
22520             enddo
22521             ract=sqrt(rcal)
22522             rocal=1.5
22523             epscalc=0.2
22524             r0p=0.5*(rocal+sig0(itype(i,1)))
22525             r06 = r0p**6
22526             r012 = r06*r06
22527             Evan1=epscalc*(r012/rcal**6)
22528             Evan2=epscalc*2*(r06/rcal**3)
22529             r4 = rcal**4
22530             r7 = rcal**7
22531             do k=1,3
22532               dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
22533               dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
22534             enddo
22535             do k=1,3
22536               dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
22537             enddo
22538                  ecation_prot = ecation_prot+ Evan1+Evan2
22539             do  k=1,3
22540                gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22541                dEtotalCm(k)
22542               gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
22543               gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
22544              enddo
22545          endif ! 13-16 residues
22546        enddo !j
22547        enddo !i
22548        return
22549        end subroutine ecat_prot
22550
22551 !----------------------------------------------------------------------------
22552 !-----------------------------------------------------------------------------
22553 !-----------------------------------------------------------------------------
22554       subroutine eprot_sc_base(escbase)
22555       use calc_data
22556 !      implicit real*8 (a-h,o-z)
22557 !      include 'DIMENSIONS'
22558 !      include 'COMMON.GEO'
22559 !      include 'COMMON.VAR'
22560 !      include 'COMMON.LOCAL'
22561 !      include 'COMMON.CHAIN'
22562 !      include 'COMMON.DERIV'
22563 !      include 'COMMON.NAMES'
22564 !      include 'COMMON.INTERACT'
22565 !      include 'COMMON.IOUNITS'
22566 !      include 'COMMON.CALC'
22567 !      include 'COMMON.CONTROL'
22568 !      include 'COMMON.SBRIDGE'
22569       logical :: lprn
22570 !el local variables
22571       integer :: iint,itypi,itypi1,itypj,subchap
22572       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
22573       real(kind=8) :: evdw,sig0ij
22574       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22575                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
22576                     sslipi,sslipj,faclip
22577       integer :: ii
22578       real(kind=8) :: fracinbuf
22579        real (kind=8) :: escbase
22580        real (kind=8),dimension(4):: ener
22581        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
22582        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
22583         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
22584         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
22585         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
22586         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
22587         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
22588         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
22589        real(kind=8),dimension(3,2)::chead,erhead_tail
22590        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
22591        integer troll
22592        eps_out=80.0d0
22593        escbase=0.0d0
22594 !       do i=1,nres_molec(1)
22595         do i=ibond_start,ibond_end
22596         if (itype(i,1).eq.ntyp1_molec(1)) cycle
22597         itypi  = itype(i,1)
22598         dxi    = dc_norm(1,nres+i)
22599         dyi    = dc_norm(2,nres+i)
22600         dzi    = dc_norm(3,nres+i)
22601         dsci_inv = vbld_inv(i+nres)
22602         xi=c(1,nres+i)
22603         yi=c(2,nres+i)
22604         zi=c(3,nres+i)
22605         xi=mod(xi,boxxsize)
22606          if (xi.lt.0) xi=xi+boxxsize
22607         yi=mod(yi,boxysize)
22608          if (yi.lt.0) yi=yi+boxysize
22609         zi=mod(zi,boxzsize)
22610          if (zi.lt.0) zi=zi+boxzsize
22611          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
22612            itypj= itype(j,2)
22613            if (itype(j,2).eq.ntyp1_molec(2))cycle
22614            xj=c(1,j+nres)
22615            yj=c(2,j+nres)
22616            zj=c(3,j+nres)
22617            xj=dmod(xj,boxxsize)
22618            if (xj.lt.0) xj=xj+boxxsize
22619            yj=dmod(yj,boxysize)
22620            if (yj.lt.0) yj=yj+boxysize
22621            zj=dmod(zj,boxzsize)
22622            if (zj.lt.0) zj=zj+boxzsize
22623           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22624           xj_safe=xj
22625           yj_safe=yj
22626           zj_safe=zj
22627           subchap=0
22628
22629           do xshift=-1,1
22630           do yshift=-1,1
22631           do zshift=-1,1
22632           xj=xj_safe+xshift*boxxsize
22633           yj=yj_safe+yshift*boxysize
22634           zj=zj_safe+zshift*boxzsize
22635           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22636           if(dist_temp.lt.dist_init) then
22637             dist_init=dist_temp
22638             xj_temp=xj
22639             yj_temp=yj
22640             zj_temp=zj
22641             subchap=1
22642           endif
22643           enddo
22644           enddo
22645           enddo
22646           if (subchap.eq.1) then
22647           xj=xj_temp-xi
22648           yj=yj_temp-yi
22649           zj=zj_temp-zi
22650           else
22651           xj=xj_safe-xi
22652           yj=yj_safe-yi
22653           zj=zj_safe-zi
22654           endif
22655           dxj = dc_norm( 1, nres+j )
22656           dyj = dc_norm( 2, nres+j )
22657           dzj = dc_norm( 3, nres+j )
22658 !          print *,i,j,itypi,itypj
22659           d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
22660           d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
22661 !          d1i=0.0d0
22662 !          d1j=0.0d0
22663 !          BetaT = 1.0d0 / (298.0d0 * Rb)
22664 ! Gay-berne var's
22665           sig0ij = sigma_scbase( itypi,itypj )
22666           chi1   = chi_scbase( itypi, itypj,1 )
22667           chi2   = chi_scbase( itypi, itypj,2 )
22668 !          chi1=0.0d0
22669 !          chi2=0.0d0
22670           chi12  = chi1 * chi2
22671           chip1  = chipp_scbase( itypi, itypj,1 )
22672           chip2  = chipp_scbase( itypi, itypj,2 )
22673 !          chip1=0.0d0
22674 !          chip2=0.0d0
22675           chip12 = chip1 * chip2
22676 ! not used by momo potential, but needed by sc_angular which is shared
22677 ! by all energy_potential subroutines
22678           alf1   = 0.0d0
22679           alf2   = 0.0d0
22680           alf12  = 0.0d0
22681           a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
22682 !       a12sq = a12sq * a12sq
22683 ! charge of amino acid itypi is...
22684           chis1 = chis_scbase(itypi,itypj,1)
22685           chis2 = chis_scbase(itypi,itypj,2)
22686           chis12 = chis1 * chis2
22687           sig1 = sigmap1_scbase(itypi,itypj)
22688           sig2 = sigmap2_scbase(itypi,itypj)
22689 !       write (*,*) "sig1 = ", sig1
22690 !       write (*,*) "sig2 = ", sig2
22691 ! alpha factors from Fcav/Gcav
22692           b1 = alphasur_scbase(1,itypi,itypj)
22693 !          b1=0.0d0
22694           b2 = alphasur_scbase(2,itypi,itypj)
22695           b3 = alphasur_scbase(3,itypi,itypj)
22696           b4 = alphasur_scbase(4,itypi,itypj)
22697 ! used to determine whether we want to do quadrupole calculations
22698 ! used by Fgb
22699        eps_in = epsintab_scbase(itypi,itypj)
22700        if (eps_in.eq.0.0) eps_in=1.0
22701        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22702 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
22703 !-------------------------------------------------------------------
22704 ! tail location and distance calculations
22705        DO k = 1,3
22706 ! location of polar head is computed by taking hydrophobic centre
22707 ! and moving by a d1 * dc_norm vector
22708 ! see unres publications for very informative images
22709         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
22710         chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
22711 ! distance
22712 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22713 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22714         Rhead_distance(k) = chead(k,2) - chead(k,1)
22715        END DO
22716 ! pitagoras (root of sum of squares)
22717        Rhead = dsqrt( &
22718           (Rhead_distance(1)*Rhead_distance(1)) &
22719         + (Rhead_distance(2)*Rhead_distance(2)) &
22720         + (Rhead_distance(3)*Rhead_distance(3)))
22721 !-------------------------------------------------------------------
22722 ! zero everything that should be zero'ed
22723        evdwij = 0.0d0
22724        ECL = 0.0d0
22725        Elj = 0.0d0
22726        Equad = 0.0d0
22727        Epol = 0.0d0
22728        Fcav=0.0d0
22729        eheadtail = 0.0d0
22730        dGCLdOM1 = 0.0d0
22731        dGCLdOM2 = 0.0d0
22732        dGCLdOM12 = 0.0d0
22733        dPOLdOM1 = 0.0d0
22734        dPOLdOM2 = 0.0d0
22735           Fcav = 0.0d0
22736           dFdR = 0.0d0
22737           dCAVdOM1  = 0.0d0
22738           dCAVdOM2  = 0.0d0
22739           dCAVdOM12 = 0.0d0
22740           dscj_inv = vbld_inv(j+nres)
22741 !          print *,i,j,dscj_inv,dsci_inv
22742 ! rij holds 1/(distance of Calpha atoms)
22743           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22744           rij  = dsqrt(rrij)
22745 !----------------------------
22746           CALL sc_angular
22747 ! this should be in elgrad_init but om's are calculated by sc_angular
22748 ! which in turn is used by older potentials
22749 ! om = omega, sqom = om^2
22750           sqom1  = om1 * om1
22751           sqom2  = om2 * om2
22752           sqom12 = om12 * om12
22753
22754 ! now we calculate EGB - Gey-Berne
22755 ! It will be summed up in evdwij and saved in evdw
22756           sigsq     = 1.0D0  / sigsq
22757           sig       = sig0ij * dsqrt(sigsq)
22758 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22759           rij_shift = 1.0/rij - sig + sig0ij
22760           IF (rij_shift.le.0.0D0) THEN
22761            evdw = 1.0D20
22762            RETURN
22763           END IF
22764           sigder = -sig * sigsq
22765           rij_shift = 1.0D0 / rij_shift
22766           fac       = rij_shift**expon
22767           c1        = fac  * fac * aa_scbase(itypi,itypj)
22768 !          c1        = 0.0d0
22769           c2        = fac  * bb_scbase(itypi,itypj)
22770 !          c2        = 0.0d0
22771           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22772           eps2der   = eps3rt * evdwij
22773           eps3der   = eps2rt * evdwij
22774 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22775           evdwij    = eps2rt * eps3rt * evdwij
22776           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22777           fac    = -expon * (c1 + evdwij) * rij_shift
22778           sigder = fac * sigder
22779 !          fac    = rij * fac
22780 ! Calculate distance derivative
22781           gg(1) =  fac
22782           gg(2) =  fac
22783           gg(3) =  fac
22784 !          if (b2.gt.0.0) then
22785           fac = chis1 * sqom1 + chis2 * sqom2 &
22786           - 2.0d0 * chis12 * om1 * om2 * om12
22787 ! we will use pom later in Gcav, so dont mess with it!
22788           pom = 1.0d0 - chis1 * chis2 * sqom12
22789           Lambf = (1.0d0 - (fac / pom))
22790           Lambf = dsqrt(Lambf)
22791           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
22792 !       write (*,*) "sparrow = ", sparrow
22793           Chif = 1.0d0/rij * sparrow
22794           ChiLambf = Chif * Lambf
22795           eagle = dsqrt(ChiLambf)
22796           bat = ChiLambf ** 11.0d0
22797           top = b1 * ( eagle + b2 * ChiLambf - b3 )
22798           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
22799           botsq = bot * bot
22800           Fcav = top / bot
22801 !          print *,i,j,Fcav
22802           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
22803           dbot = 12.0d0 * b4 * bat * Lambf
22804           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
22805 !       dFdR = 0.0d0
22806 !      write (*,*) "dFcav/dR = ", dFdR
22807           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
22808           dbot = 12.0d0 * b4 * bat * Chif
22809           eagle = Lambf * pom
22810           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
22811           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
22812           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
22813               * (chis2 * om2 * om12 - om1) / (eagle * pom)
22814
22815           dFdL = ((dtop * bot - top * dbot) / botsq)
22816 !       dFdL = 0.0d0
22817           dCAVdOM1  = dFdL * ( dFdOM1 )
22818           dCAVdOM2  = dFdL * ( dFdOM2 )
22819           dCAVdOM12 = dFdL * ( dFdOM12 )
22820
22821           ertail(1) = xj*rij
22822           ertail(2) = yj*rij
22823           ertail(3) = zj*rij
22824 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
22825 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
22826 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
22827 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
22828 !           print *,"EOMY",eom1,eom2,eom12
22829 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
22830 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
22831 ! here dtail=0.0
22832 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
22833 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
22834        DO k = 1, 3
22835 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
22836 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
22837         pom = ertail(k)
22838 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
22839         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
22840                   - (( dFdR + gg(k) ) * pom)
22841 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
22842 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22843 !     &             - ( dFdR * pom )
22844         pom = ertail(k)
22845 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
22846         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
22847                   + (( dFdR + gg(k) ) * pom)
22848 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22849 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22850 !c!     &             + ( dFdR * pom )
22851
22852         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
22853                   - (( dFdR + gg(k) ) * ertail(k))
22854 !c!     &             - ( dFdR * ertail(k))
22855
22856         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
22857                   + (( dFdR + gg(k) ) * ertail(k))
22858 !c!     &             + ( dFdR * ertail(k))
22859
22860         gg(k) = 0.0d0
22861 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
22862 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
22863       END DO
22864
22865 !          else
22866
22867 !          endif
22868 !Now dipole-dipole
22869          if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
22870        w1 = wdipdip_scbase(1,itypi,itypj)
22871        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
22872        w3 = wdipdip_scbase(2,itypi,itypj)
22873 !c!-------------------------------------------------------------------
22874 !c! ECL
22875        fac = (om12 - 3.0d0 * om1 * om2)
22876        c1 = (w1 / (Rhead**3.0d0)) * fac
22877        c2 = (w2 / Rhead ** 6.0d0)  &
22878          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
22879        c3= (w3/ Rhead ** 6.0d0)  &
22880          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
22881        ECL = c1 - c2 + c3
22882 !c!       write (*,*) "w1 = ", w1
22883 !c!       write (*,*) "w2 = ", w2
22884 !c!       write (*,*) "om1 = ", om1
22885 !c!       write (*,*) "om2 = ", om2
22886 !c!       write (*,*) "om12 = ", om12
22887 !c!       write (*,*) "fac = ", fac
22888 !c!       write (*,*) "c1 = ", c1
22889 !c!       write (*,*) "c2 = ", c2
22890 !c!       write (*,*) "Ecl = ", Ecl
22891 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
22892 !c!       write (*,*) "c2_2 = ",
22893 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
22894 !c!-------------------------------------------------------------------
22895 !c! dervative of ECL is GCL...
22896 !c! dECL/dr
22897        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
22898        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
22899          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
22900        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
22901          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
22902        dGCLdR = c1 - c2 + c3
22903 !c! dECL/dom1
22904        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
22905        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
22906          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
22907        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
22908        dGCLdOM1 = c1 - c2 + c3
22909 !c! dECL/dom2
22910        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
22911        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
22912          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
22913        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
22914        dGCLdOM2 = c1 - c2 + c3
22915 !c! dECL/dom12
22916        c1 = w1 / (Rhead ** 3.0d0)
22917        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
22918        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
22919        dGCLdOM12 = c1 - c2 + c3
22920        DO k= 1, 3
22921         erhead(k) = Rhead_distance(k)/Rhead
22922        END DO
22923        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
22924        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
22925        facd1 = d1i * vbld_inv(i+nres)
22926        facd2 = d1j * vbld_inv(j+nres)
22927        DO k = 1, 3
22928
22929         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
22930         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
22931                   - dGCLdR * pom
22932         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
22933         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
22934                   + dGCLdR * pom
22935
22936         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
22937                   - dGCLdR * erhead(k)
22938         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
22939                   + dGCLdR * erhead(k)
22940        END DO
22941        endif
22942 !now charge with dipole eg. ARG-dG
22943        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
22944       alphapol1 = alphapol_scbase(itypi,itypj)
22945        w1        = wqdip_scbase(1,itypi,itypj)
22946        w2        = wqdip_scbase(2,itypi,itypj)
22947 !       w1=0.0d0
22948 !       w2=0.0d0
22949 !       pis       = sig0head_scbase(itypi,itypj)
22950 !       eps_head   = epshead_scbase(itypi,itypj)
22951 !c!-------------------------------------------------------------------
22952 !c! R1 - distance between head of ith side chain and tail of jth sidechain
22953        R1 = 0.0d0
22954        DO k = 1, 3
22955 !c! Calculate head-to-tail distances tail is center of side-chain
22956         R1=R1+(c(k,j+nres)-chead(k,1))**2
22957        END DO
22958 !c! Pitagoras
22959        R1 = dsqrt(R1)
22960
22961 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
22962 !c!     &        +dhead(1,1,itypi,itypj))**2))
22963 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
22964 !c!     &        +dhead(2,1,itypi,itypj))**2))
22965
22966 !c!-------------------------------------------------------------------
22967 !c! ecl
22968        sparrow  = w1  *  om1
22969        hawk     = w2 *  (1.0d0 - sqom2)
22970        Ecl = sparrow / Rhead**2.0d0 &
22971            - hawk    / Rhead**4.0d0
22972 !c!-------------------------------------------------------------------
22973 !c! derivative of ecl is Gcl
22974 !c! dF/dr part
22975        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
22976                 + 4.0d0 * hawk    / Rhead**5.0d0
22977 !c! dF/dom1
22978        dGCLdOM1 = (w1) / (Rhead**2.0d0)
22979 !c! dF/dom2
22980        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
22981 !c--------------------------------------------------------------------
22982 !c Polarization energy
22983 !c Epol
22984        MomoFac1 = (1.0d0 - chi1 * sqom2)
22985        RR1  = R1 * R1 / MomoFac1
22986        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
22987        fgb1 = sqrt( RR1 + a12sq * ee1)
22988 !       eps_inout_fac=0.0d0
22989        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
22990 ! derivative of Epol is Gpol...
22991        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
22992                 / (fgb1 ** 5.0d0)
22993        dFGBdR1 = ( (R1 / MomoFac1) &
22994              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
22995              / ( 2.0d0 * fgb1 )
22996        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
22997                * (2.0d0 - 0.5d0 * ee1) ) &
22998                / (2.0d0 * fgb1)
22999        dPOLdR1 = dPOLdFGB1 * dFGBdR1
23000 !       dPOLdR1 = 0.0d0
23001        dPOLdOM1 = 0.0d0
23002        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
23003        DO k = 1, 3
23004         erhead(k) = Rhead_distance(k)/Rhead
23005         erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
23006        END DO
23007
23008        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23009        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23010        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
23011 !       bat=0.0d0
23012        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
23013        facd1 = d1i * vbld_inv(i+nres)
23014        facd2 = d1j * vbld_inv(j+nres)
23015 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23016
23017        DO k = 1, 3
23018         hawk = (erhead_tail(k,1) + &
23019         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
23020 !        facd1=0.0d0
23021 !        facd2=0.0d0
23022         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23023         gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
23024                    - dGCLdR * pom &
23025                    - dPOLdR1 *  (erhead_tail(k,1))
23026 !     &             - dGLJdR * pom
23027
23028         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23029         gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
23030                    + dGCLdR * pom  &
23031                    + dPOLdR1 * (erhead_tail(k,1))
23032 !     &             + dGLJdR * pom
23033
23034
23035         gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
23036                   - dGCLdR * erhead(k) &
23037                   - dPOLdR1 * erhead_tail(k,1)
23038 !     &             - dGLJdR * erhead(k)
23039
23040         gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
23041                   + dGCLdR * erhead(k)  &
23042                   + dPOLdR1 * erhead_tail(k,1)
23043 !     &             + dGLJdR * erhead(k)
23044
23045        END DO
23046        endif
23047 !       print *,i,j,evdwij,epol,Fcav,ECL
23048        escbase=escbase+evdwij+epol+Fcav+ECL
23049        call sc_grad_scbase
23050          enddo
23051       enddo
23052
23053       return
23054       end subroutine eprot_sc_base
23055       SUBROUTINE sc_grad_scbase
23056       use calc_data
23057
23058        real (kind=8) :: dcosom1(3),dcosom2(3)
23059        eom1  =    &
23060               eps2der * eps2rt_om1   &
23061             - 2.0D0 * alf1 * eps3der &
23062             + sigder * sigsq_om1     &
23063             + dCAVdOM1               &
23064             + dGCLdOM1               &
23065             + dPOLdOM1
23066
23067        eom2  =  &
23068               eps2der * eps2rt_om2   &
23069             + 2.0D0 * alf2 * eps3der &
23070             + sigder * sigsq_om2     &
23071             + dCAVdOM2               &
23072             + dGCLdOM2               &
23073             + dPOLdOM2
23074
23075        eom12 =    &
23076               evdwij  * eps1_om12     &
23077             + eps2der * eps2rt_om12   &
23078             - 2.0D0 * alf12 * eps3der &
23079             + sigder *sigsq_om12      &
23080             + dCAVdOM12               &
23081             + dGCLdOM12
23082
23083 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23084 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23085 !               gg(1),gg(2),"rozne"
23086        DO k = 1, 3
23087         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
23088         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
23089         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23090         gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
23091                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23092                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23093         gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
23094                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23095                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23096         gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
23097         gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
23098        END DO
23099        RETURN
23100       END SUBROUTINE sc_grad_scbase
23101
23102
23103       subroutine epep_sc_base(epepbase)
23104       use calc_data
23105       logical :: lprn
23106 !el local variables
23107       integer :: iint,itypi,itypi1,itypj,subchap
23108       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23109       real(kind=8) :: evdw,sig0ij
23110       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23111                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23112                     sslipi,sslipj,faclip
23113       integer :: ii
23114       real(kind=8) :: fracinbuf
23115        real (kind=8) :: epepbase
23116        real (kind=8),dimension(4):: ener
23117        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23118        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23119         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
23120         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23121         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23122         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23123         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23124         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23125        real(kind=8),dimension(3,2)::chead,erhead_tail
23126        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23127        integer troll
23128        eps_out=80.0d0
23129        epepbase=0.0d0
23130 !       do i=1,nres_molec(1)-1
23131         do i=ibond_start,ibond_end
23132         if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
23133 !C        itypi  = itype(i,1)
23134         dxi    = dc_norm(1,i)
23135         dyi    = dc_norm(2,i)
23136         dzi    = dc_norm(3,i)
23137 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
23138         dsci_inv = vbld_inv(i+1)/2.0
23139         xi=(c(1,i)+c(1,i+1))/2.0
23140         yi=(c(2,i)+c(2,i+1))/2.0
23141         zi=(c(3,i)+c(3,i+1))/2.0
23142         xi=mod(xi,boxxsize)
23143          if (xi.lt.0) xi=xi+boxxsize
23144         yi=mod(yi,boxysize)
23145          if (yi.lt.0) yi=yi+boxysize
23146         zi=mod(zi,boxzsize)
23147          if (zi.lt.0) zi=zi+boxzsize
23148          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23149            itypj= itype(j,2)
23150            if (itype(j,2).eq.ntyp1_molec(2))cycle
23151            xj=c(1,j+nres)
23152            yj=c(2,j+nres)
23153            zj=c(3,j+nres)
23154            xj=dmod(xj,boxxsize)
23155            if (xj.lt.0) xj=xj+boxxsize
23156            yj=dmod(yj,boxysize)
23157            if (yj.lt.0) yj=yj+boxysize
23158            zj=dmod(zj,boxzsize)
23159            if (zj.lt.0) zj=zj+boxzsize
23160           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23161           xj_safe=xj
23162           yj_safe=yj
23163           zj_safe=zj
23164           subchap=0
23165
23166           do xshift=-1,1
23167           do yshift=-1,1
23168           do zshift=-1,1
23169           xj=xj_safe+xshift*boxxsize
23170           yj=yj_safe+yshift*boxysize
23171           zj=zj_safe+zshift*boxzsize
23172           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23173           if(dist_temp.lt.dist_init) then
23174             dist_init=dist_temp
23175             xj_temp=xj
23176             yj_temp=yj
23177             zj_temp=zj
23178             subchap=1
23179           endif
23180           enddo
23181           enddo
23182           enddo
23183           if (subchap.eq.1) then
23184           xj=xj_temp-xi
23185           yj=yj_temp-yi
23186           zj=zj_temp-zi
23187           else
23188           xj=xj_safe-xi
23189           yj=yj_safe-yi
23190           zj=zj_safe-zi
23191           endif
23192           dxj = dc_norm( 1, nres+j )
23193           dyj = dc_norm( 2, nres+j )
23194           dzj = dc_norm( 3, nres+j )
23195 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
23196 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
23197
23198 ! Gay-berne var's
23199           sig0ij = sigma_pepbase(itypj )
23200           chi1   = chi_pepbase(itypj,1 )
23201           chi2   = chi_pepbase(itypj,2 )
23202 !          chi1=0.0d0
23203 !          chi2=0.0d0
23204           chi12  = chi1 * chi2
23205           chip1  = chipp_pepbase(itypj,1 )
23206           chip2  = chipp_pepbase(itypj,2 )
23207 !          chip1=0.0d0
23208 !          chip2=0.0d0
23209           chip12 = chip1 * chip2
23210           chis1 = chis_pepbase(itypj,1)
23211           chis2 = chis_pepbase(itypj,2)
23212           chis12 = chis1 * chis2
23213           sig1 = sigmap1_pepbase(itypj)
23214           sig2 = sigmap2_pepbase(itypj)
23215 !       write (*,*) "sig1 = ", sig1
23216 !       write (*,*) "sig2 = ", sig2
23217        DO k = 1,3
23218 ! location of polar head is computed by taking hydrophobic centre
23219 ! and moving by a d1 * dc_norm vector
23220 ! see unres publications for very informative images
23221         chead(k,1) = (c(k,i)+c(k,i+1))/2.0
23222 ! + d1i * dc_norm(k, i+nres)
23223         chead(k,2) = c(k, j+nres)
23224 ! + d1j * dc_norm(k, j+nres)
23225 ! distance
23226 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23227 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23228         Rhead_distance(k) = chead(k,2) - chead(k,1)
23229 !        print *,gvdwc_pepbase(k,i)
23230
23231        END DO
23232        Rhead = dsqrt( &
23233           (Rhead_distance(1)*Rhead_distance(1)) &
23234         + (Rhead_distance(2)*Rhead_distance(2)) &
23235         + (Rhead_distance(3)*Rhead_distance(3)))
23236
23237 ! alpha factors from Fcav/Gcav
23238           b1 = alphasur_pepbase(1,itypj)
23239 !          b1=0.0d0
23240           b2 = alphasur_pepbase(2,itypj)
23241           b3 = alphasur_pepbase(3,itypj)
23242           b4 = alphasur_pepbase(4,itypj)
23243           alf1   = 0.0d0
23244           alf2   = 0.0d0
23245           alf12  = 0.0d0
23246           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23247 !          print *,i,j,rrij
23248           rij  = dsqrt(rrij)
23249 !----------------------------
23250        evdwij = 0.0d0
23251        ECL = 0.0d0
23252        Elj = 0.0d0
23253        Equad = 0.0d0
23254        Epol = 0.0d0
23255        Fcav=0.0d0
23256        eheadtail = 0.0d0
23257        dGCLdOM1 = 0.0d0
23258        dGCLdOM2 = 0.0d0
23259        dGCLdOM12 = 0.0d0
23260        dPOLdOM1 = 0.0d0
23261        dPOLdOM2 = 0.0d0
23262           Fcav = 0.0d0
23263           dFdR = 0.0d0
23264           dCAVdOM1  = 0.0d0
23265           dCAVdOM2  = 0.0d0
23266           dCAVdOM12 = 0.0d0
23267           dscj_inv = vbld_inv(j+nres)
23268           CALL sc_angular
23269 ! this should be in elgrad_init but om's are calculated by sc_angular
23270 ! which in turn is used by older potentials
23271 ! om = omega, sqom = om^2
23272           sqom1  = om1 * om1
23273           sqom2  = om2 * om2
23274           sqom12 = om12 * om12
23275
23276 ! now we calculate EGB - Gey-Berne
23277 ! It will be summed up in evdwij and saved in evdw
23278           sigsq     = 1.0D0  / sigsq
23279           sig       = sig0ij * dsqrt(sigsq)
23280           rij_shift = 1.0/rij - sig + sig0ij
23281           IF (rij_shift.le.0.0D0) THEN
23282            evdw = 1.0D20
23283            RETURN
23284           END IF
23285           sigder = -sig * sigsq
23286           rij_shift = 1.0D0 / rij_shift
23287           fac       = rij_shift**expon
23288           c1        = fac  * fac * aa_pepbase(itypj)
23289 !          c1        = 0.0d0
23290           c2        = fac  * bb_pepbase(itypj)
23291 !          c2        = 0.0d0
23292           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23293           eps2der   = eps3rt * evdwij
23294           eps3der   = eps2rt * evdwij
23295 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23296           evdwij    = eps2rt * eps3rt * evdwij
23297           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23298           fac    = -expon * (c1 + evdwij) * rij_shift
23299           sigder = fac * sigder
23300 !          fac    = rij * fac
23301 ! Calculate distance derivative
23302           gg(1) =  fac
23303           gg(2) =  fac
23304           gg(3) =  fac
23305           fac = chis1 * sqom1 + chis2 * sqom2 &
23306           - 2.0d0 * chis12 * om1 * om2 * om12
23307 ! we will use pom later in Gcav, so dont mess with it!
23308           pom = 1.0d0 - chis1 * chis2 * sqom12
23309           Lambf = (1.0d0 - (fac / pom))
23310           Lambf = dsqrt(Lambf)
23311           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23312 !       write (*,*) "sparrow = ", sparrow
23313           Chif = 1.0d0/rij * sparrow
23314           ChiLambf = Chif * Lambf
23315           eagle = dsqrt(ChiLambf)
23316           bat = ChiLambf ** 11.0d0
23317           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23318           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23319           botsq = bot * bot
23320           Fcav = top / bot
23321 !          print *,i,j,Fcav
23322           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23323           dbot = 12.0d0 * b4 * bat * Lambf
23324           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23325 !       dFdR = 0.0d0
23326 !      write (*,*) "dFcav/dR = ", dFdR
23327           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23328           dbot = 12.0d0 * b4 * bat * Chif
23329           eagle = Lambf * pom
23330           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23331           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23332           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23333               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23334
23335           dFdL = ((dtop * bot - top * dbot) / botsq)
23336 !       dFdL = 0.0d0
23337           dCAVdOM1  = dFdL * ( dFdOM1 )
23338           dCAVdOM2  = dFdL * ( dFdOM2 )
23339           dCAVdOM12 = dFdL * ( dFdOM12 )
23340
23341           ertail(1) = xj*rij
23342           ertail(2) = yj*rij
23343           ertail(3) = zj*rij
23344        DO k = 1, 3
23345 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23346 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23347         pom = ertail(k)
23348 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23349         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
23350                   - (( dFdR + gg(k) ) * pom)/2.0
23351 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
23352 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23353 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23354 !     &             - ( dFdR * pom )
23355         pom = ertail(k)
23356 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23357         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
23358                   + (( dFdR + gg(k) ) * pom)
23359 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23360 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23361 !c!     &             + ( dFdR * pom )
23362
23363         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
23364                   - (( dFdR + gg(k) ) * ertail(k))/2.0
23365 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
23366
23367 !c!     &             - ( dFdR * ertail(k))
23368
23369         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
23370                   + (( dFdR + gg(k) ) * ertail(k))
23371 !c!     &             + ( dFdR * ertail(k))
23372
23373         gg(k) = 0.0d0
23374 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23375 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23376       END DO
23377
23378
23379        w1 = wdipdip_pepbase(1,itypj)
23380        w2 = -wdipdip_pepbase(3,itypj)/2.0
23381        w3 = wdipdip_pepbase(2,itypj)
23382 !       w1=0.0d0
23383 !       w2=0.0d0
23384 !c!-------------------------------------------------------------------
23385 !c! ECL
23386 !       w3=0.0d0
23387        fac = (om12 - 3.0d0 * om1 * om2)
23388        c1 = (w1 / (Rhead**3.0d0)) * fac
23389        c2 = (w2 / Rhead ** 6.0d0)  &
23390          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23391        c3= (w3/ Rhead ** 6.0d0)  &
23392          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23393
23394        ECL = c1 - c2 + c3
23395
23396        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
23397        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
23398          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
23399        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
23400          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23401
23402        dGCLdR = c1 - c2 + c3
23403 !c! dECL/dom1
23404        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
23405        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23406          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
23407        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
23408        dGCLdOM1 = c1 - c2 + c3
23409 !c! dECL/dom2
23410        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
23411        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23412          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
23413        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
23414
23415        dGCLdOM2 = c1 - c2 + c3
23416 !c! dECL/dom12
23417        c1 = w1 / (Rhead ** 3.0d0)
23418        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
23419        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
23420        dGCLdOM12 = c1 - c2 + c3
23421        DO k= 1, 3
23422         erhead(k) = Rhead_distance(k)/Rhead
23423        END DO
23424        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23425        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23426 !       facd1 = d1 * vbld_inv(i+nres)
23427 !       facd2 = d2 * vbld_inv(j+nres)
23428        DO k = 1, 3
23429
23430 !        pom = erhead(k)
23431 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23432 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
23433 !                  - dGCLdR * pom
23434         pom = erhead(k)
23435 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23436         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
23437                   + dGCLdR * pom
23438
23439         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
23440                   - dGCLdR * erhead(k)/2.0d0
23441 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
23442         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
23443                   - dGCLdR * erhead(k)/2.0d0
23444 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
23445         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
23446                   + dGCLdR * erhead(k)
23447        END DO
23448 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
23449        epepbase=epepbase+evdwij+Fcav+ECL
23450        call sc_grad_pepbase
23451        enddo
23452        enddo
23453       END SUBROUTINE epep_sc_base
23454       SUBROUTINE sc_grad_pepbase
23455       use calc_data
23456
23457        real (kind=8) :: dcosom1(3),dcosom2(3)
23458        eom1  =    &
23459               eps2der * eps2rt_om1   &
23460             - 2.0D0 * alf1 * eps3der &
23461             + sigder * sigsq_om1     &
23462             + dCAVdOM1               &
23463             + dGCLdOM1               &
23464             + dPOLdOM1
23465
23466        eom2  =  &
23467               eps2der * eps2rt_om2   &
23468             + 2.0D0 * alf2 * eps3der &
23469             + sigder * sigsq_om2     &
23470             + dCAVdOM2               &
23471             + dGCLdOM2               &
23472             + dPOLdOM2
23473
23474        eom12 =    &
23475               evdwij  * eps1_om12     &
23476             + eps2der * eps2rt_om12   &
23477             - 2.0D0 * alf12 * eps3der &
23478             + sigder *sigsq_om12      &
23479             + dCAVdOM12               &
23480             + dGCLdOM12
23481 !        om12=0.0
23482 !        eom12=0.0
23483 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23484 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
23485 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23486 !                 *dsci_inv*2.0
23487 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23488 !               gg(1),gg(2),"rozne"
23489        DO k = 1, 3
23490         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
23491         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
23492         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23493         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
23494                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23495                  *dsci_inv*2.0 &
23496                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
23497         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
23498                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
23499                  *dsci_inv*2.0 &
23500                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
23501 !         print *,eom12,eom2,om12,om2
23502 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
23503 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
23504         gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
23505                  + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
23506                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23507         gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
23508        END DO
23509        RETURN
23510       END SUBROUTINE sc_grad_pepbase
23511       subroutine eprot_sc_phosphate(escpho)
23512       use calc_data
23513 !      implicit real*8 (a-h,o-z)
23514 !      include 'DIMENSIONS'
23515 !      include 'COMMON.GEO'
23516 !      include 'COMMON.VAR'
23517 !      include 'COMMON.LOCAL'
23518 !      include 'COMMON.CHAIN'
23519 !      include 'COMMON.DERIV'
23520 !      include 'COMMON.NAMES'
23521 !      include 'COMMON.INTERACT'
23522 !      include 'COMMON.IOUNITS'
23523 !      include 'COMMON.CALC'
23524 !      include 'COMMON.CONTROL'
23525 !      include 'COMMON.SBRIDGE'
23526       logical :: lprn
23527 !el local variables
23528       integer :: iint,itypi,itypi1,itypj,subchap
23529       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23530       real(kind=8) :: evdw,sig0ij
23531       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23532                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23533                     sslipi,sslipj,faclip,alpha_sco
23534       integer :: ii
23535       real(kind=8) :: fracinbuf
23536        real (kind=8) :: escpho
23537        real (kind=8),dimension(4):: ener
23538        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23539        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23540         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
23541         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23542         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
23543         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23544         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23545         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
23546        real(kind=8),dimension(3,2)::chead,erhead_tail
23547        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23548        integer troll
23549        eps_out=80.0d0
23550        escpho=0.0d0
23551 !       do i=1,nres_molec(1)
23552         do i=ibond_start,ibond_end
23553         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23554         itypi  = itype(i,1)
23555         dxi    = dc_norm(1,nres+i)
23556         dyi    = dc_norm(2,nres+i)
23557         dzi    = dc_norm(3,nres+i)
23558         dsci_inv = vbld_inv(i+nres)
23559         xi=c(1,nres+i)
23560         yi=c(2,nres+i)
23561         zi=c(3,nres+i)
23562         xi=mod(xi,boxxsize)
23563          if (xi.lt.0) xi=xi+boxxsize
23564         yi=mod(yi,boxysize)
23565          if (yi.lt.0) yi=yi+boxysize
23566         zi=mod(zi,boxzsize)
23567          if (zi.lt.0) zi=zi+boxzsize
23568          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
23569            itypj= itype(j,2)
23570            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
23571             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
23572            xj=(c(1,j)+c(1,j+1))/2.0
23573            yj=(c(2,j)+c(2,j+1))/2.0
23574            zj=(c(3,j)+c(3,j+1))/2.0
23575            xj=dmod(xj,boxxsize)
23576            if (xj.lt.0) xj=xj+boxxsize
23577            yj=dmod(yj,boxysize)
23578            if (yj.lt.0) yj=yj+boxysize
23579            zj=dmod(zj,boxzsize)
23580            if (zj.lt.0) zj=zj+boxzsize
23581           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23582           xj_safe=xj
23583           yj_safe=yj
23584           zj_safe=zj
23585           subchap=0
23586           do xshift=-1,1
23587           do yshift=-1,1
23588           do zshift=-1,1
23589           xj=xj_safe+xshift*boxxsize
23590           yj=yj_safe+yshift*boxysize
23591           zj=zj_safe+zshift*boxzsize
23592           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23593           if(dist_temp.lt.dist_init) then
23594             dist_init=dist_temp
23595             xj_temp=xj
23596             yj_temp=yj
23597             zj_temp=zj
23598             subchap=1
23599           endif
23600           enddo
23601           enddo
23602           enddo
23603           if (subchap.eq.1) then
23604           xj=xj_temp-xi
23605           yj=yj_temp-yi
23606           zj=zj_temp-zi
23607           else
23608           xj=xj_safe-xi
23609           yj=yj_safe-yi
23610           zj=zj_safe-zi
23611           endif
23612           dxj = dc_norm( 1,j )
23613           dyj = dc_norm( 2,j )
23614           dzj = dc_norm( 3,j )
23615           dscj_inv = vbld_inv(j+1)
23616
23617 ! Gay-berne var's
23618           sig0ij = sigma_scpho(itypi )
23619           chi1   = chi_scpho(itypi,1 )
23620           chi2   = chi_scpho(itypi,2 )
23621 !          chi1=0.0d0
23622 !          chi2=0.0d0
23623           chi12  = chi1 * chi2
23624           chip1  = chipp_scpho(itypi,1 )
23625           chip2  = chipp_scpho(itypi,2 )
23626 !          chip1=0.0d0
23627 !          chip2=0.0d0
23628           chip12 = chip1 * chip2
23629           chis1 = chis_scpho(itypi,1)
23630           chis2 = chis_scpho(itypi,2)
23631           chis12 = chis1 * chis2
23632           sig1 = sigmap1_scpho(itypi)
23633           sig2 = sigmap2_scpho(itypi)
23634 !       write (*,*) "sig1 = ", sig1
23635 !       write (*,*) "sig1 = ", sig1
23636 !       write (*,*) "sig2 = ", sig2
23637 ! alpha factors from Fcav/Gcav
23638           alf1   = 0.0d0
23639           alf2   = 0.0d0
23640           alf12  = 0.0d0
23641           a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
23642
23643           b1 = alphasur_scpho(1,itypi)
23644 !          b1=0.0d0
23645           b2 = alphasur_scpho(2,itypi)
23646           b3 = alphasur_scpho(3,itypi)
23647           b4 = alphasur_scpho(4,itypi)
23648 ! used to determine whether we want to do quadrupole calculations
23649 ! used by Fgb
23650        eps_in = epsintab_scpho(itypi)
23651        if (eps_in.eq.0.0) eps_in=1.0
23652        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23653 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23654 !-------------------------------------------------------------------
23655 ! tail location and distance calculations
23656           d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
23657           d1j = 0.0
23658        DO k = 1,3
23659 ! location of polar head is computed by taking hydrophobic centre
23660 ! and moving by a d1 * dc_norm vector
23661 ! see unres publications for very informative images
23662         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23663         chead(k,2) = (c(k, j) + c(k, j+1))/2.0
23664 ! distance
23665 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23666 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23667         Rhead_distance(k) = chead(k,2) - chead(k,1)
23668        END DO
23669 ! pitagoras (root of sum of squares)
23670        Rhead = dsqrt( &
23671           (Rhead_distance(1)*Rhead_distance(1)) &
23672         + (Rhead_distance(2)*Rhead_distance(2)) &
23673         + (Rhead_distance(3)*Rhead_distance(3)))
23674        Rhead_sq=Rhead**2.0
23675 !-------------------------------------------------------------------
23676 ! zero everything that should be zero'ed
23677        evdwij = 0.0d0
23678        ECL = 0.0d0
23679        Elj = 0.0d0
23680        Equad = 0.0d0
23681        Epol = 0.0d0
23682        Fcav=0.0d0
23683        eheadtail = 0.0d0
23684        dGCLdR=0.0d0
23685        dGCLdOM1 = 0.0d0
23686        dGCLdOM2 = 0.0d0
23687        dGCLdOM12 = 0.0d0
23688        dPOLdOM1 = 0.0d0
23689        dPOLdOM2 = 0.0d0
23690           Fcav = 0.0d0
23691           dFdR = 0.0d0
23692           dCAVdOM1  = 0.0d0
23693           dCAVdOM2  = 0.0d0
23694           dCAVdOM12 = 0.0d0
23695           dscj_inv = vbld_inv(j+1)/2.0
23696 !dhead_scbasej(itypi,itypj)
23697 !          print *,i,j,dscj_inv,dsci_inv
23698 ! rij holds 1/(distance of Calpha atoms)
23699           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23700           rij  = dsqrt(rrij)
23701 !----------------------------
23702           CALL sc_angular
23703 ! this should be in elgrad_init but om's are calculated by sc_angular
23704 ! which in turn is used by older potentials
23705 ! om = omega, sqom = om^2
23706           sqom1  = om1 * om1
23707           sqom2  = om2 * om2
23708           sqom12 = om12 * om12
23709
23710 ! now we calculate EGB - Gey-Berne
23711 ! It will be summed up in evdwij and saved in evdw
23712           sigsq     = 1.0D0  / sigsq
23713           sig       = sig0ij * dsqrt(sigsq)
23714 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23715           rij_shift = 1.0/rij - sig + sig0ij
23716           IF (rij_shift.le.0.0D0) THEN
23717            evdw = 1.0D20
23718            RETURN
23719           END IF
23720           sigder = -sig * sigsq
23721           rij_shift = 1.0D0 / rij_shift
23722           fac       = rij_shift**expon
23723           c1        = fac  * fac * aa_scpho(itypi)
23724 !          c1        = 0.0d0
23725           c2        = fac  * bb_scpho(itypi)
23726 !          c2        = 0.0d0
23727           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23728           eps2der   = eps3rt * evdwij
23729           eps3der   = eps2rt * evdwij
23730 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23731           evdwij    = eps2rt * eps3rt * evdwij
23732           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23733           fac    = -expon * (c1 + evdwij) * rij_shift
23734           sigder = fac * sigder
23735 !          fac    = rij * fac
23736 ! Calculate distance derivative
23737           gg(1) =  fac
23738           gg(2) =  fac
23739           gg(3) =  fac
23740           fac = chis1 * sqom1 + chis2 * sqom2 &
23741           - 2.0d0 * chis12 * om1 * om2 * om12
23742 ! we will use pom later in Gcav, so dont mess with it!
23743           pom = 1.0d0 - chis1 * chis2 * sqom12
23744           Lambf = (1.0d0 - (fac / pom))
23745           Lambf = dsqrt(Lambf)
23746           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23747 !       write (*,*) "sparrow = ", sparrow
23748           Chif = 1.0d0/rij * sparrow
23749           ChiLambf = Chif * Lambf
23750           eagle = dsqrt(ChiLambf)
23751           bat = ChiLambf ** 11.0d0
23752           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23753           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23754           botsq = bot * bot
23755           Fcav = top / bot
23756           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23757           dbot = 12.0d0 * b4 * bat * Lambf
23758           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23759 !       dFdR = 0.0d0
23760 !      write (*,*) "dFcav/dR = ", dFdR
23761           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23762           dbot = 12.0d0 * b4 * bat * Chif
23763           eagle = Lambf * pom
23764           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23765           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23766           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23767               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23768
23769           dFdL = ((dtop * bot - top * dbot) / botsq)
23770 !       dFdL = 0.0d0
23771           dCAVdOM1  = dFdL * ( dFdOM1 )
23772           dCAVdOM2  = dFdL * ( dFdOM2 )
23773           dCAVdOM12 = dFdL * ( dFdOM12 )
23774
23775           ertail(1) = xj*rij
23776           ertail(2) = yj*rij
23777           ertail(3) = zj*rij
23778        DO k = 1, 3
23779 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23780 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23781 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
23782
23783         pom = ertail(k)
23784 !        print *,pom,gg(k),dFdR
23785 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23786         gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
23787                   - (( dFdR + gg(k) ) * pom)
23788 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23789 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23790 !     &             - ( dFdR * pom )
23791 !        pom = ertail(k)
23792 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23793 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
23794 !                  + (( dFdR + gg(k) ) * pom)
23795 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23796 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23797 !c!     &             + ( dFdR * pom )
23798
23799         gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
23800                   - (( dFdR + gg(k) ) * ertail(k))
23801 !c!     &             - ( dFdR * ertail(k))
23802
23803         gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
23804                   + (( dFdR + gg(k) ) * ertail(k))/2.0
23805
23806         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
23807                   + (( dFdR + gg(k) ) * ertail(k))/2.0
23808
23809 !c!     &             + ( dFdR * ertail(k))
23810
23811         gg(k) = 0.0d0
23812         ENDDO
23813 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23814 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23815 !      alphapol1 = alphapol_scpho(itypi)
23816        if (wqq_scpho(itypi).ne.0.0) then
23817        Qij=wqq_scpho(itypi)/eps_in
23818        alpha_sco=1.d0/alphi_scpho(itypi)
23819 !       Qij=0.0
23820        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
23821 !c! derivative of Ecl is Gcl...
23822        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
23823                 (Rhead*alpha_sco+1) ) / Rhead_sq
23824        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
23825        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
23826        w1        = wqdip_scpho(1,itypi)
23827        w2        = wqdip_scpho(2,itypi)
23828 !       w1=0.0d0
23829 !       w2=0.0d0
23830 !       pis       = sig0head_scbase(itypi,itypj)
23831 !       eps_head   = epshead_scbase(itypi,itypj)
23832 !c!-------------------------------------------------------------------
23833
23834 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
23835 !c!     &        +dhead(1,1,itypi,itypj))**2))
23836 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
23837 !c!     &        +dhead(2,1,itypi,itypj))**2))
23838
23839 !c!-------------------------------------------------------------------
23840 !c! ecl
23841        sparrow  = w1  *  om1
23842        hawk     = w2 *  (1.0d0 - sqom2)
23843        Ecl = sparrow / Rhead**2.0d0 &
23844            - hawk    / Rhead**4.0d0
23845 !c!-------------------------------------------------------------------
23846        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
23847            1.0/rij,sparrow
23848
23849 !c! derivative of ecl is Gcl
23850 !c! dF/dr part
23851        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
23852                 + 4.0d0 * hawk    / Rhead**5.0d0
23853 !c! dF/dom1
23854        dGCLdOM1 = (w1) / (Rhead**2.0d0)
23855 !c! dF/dom2
23856        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
23857        endif
23858
23859 !c--------------------------------------------------------------------
23860 !c Polarization energy
23861 !c Epol
23862        R1 = 0.0d0
23863        DO k = 1, 3
23864 !c! Calculate head-to-tail distances tail is center of side-chain
23865         R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
23866        END DO
23867 !c! Pitagoras
23868        R1 = dsqrt(R1)
23869
23870       alphapol1 = alphapol_scpho(itypi)
23871 !      alphapol1=0.0
23872        MomoFac1 = (1.0d0 - chi2 * sqom1)
23873        RR1  = R1 * R1 / MomoFac1
23874        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
23875 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
23876        fgb1 = sqrt( RR1 + a12sq * ee1)
23877 !       eps_inout_fac=0.0d0
23878        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
23879 ! derivative of Epol is Gpol...
23880        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
23881                 / (fgb1 ** 5.0d0)
23882        dFGBdR1 = ( (R1 / MomoFac1) &
23883              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
23884              / ( 2.0d0 * fgb1 )
23885        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
23886                * (2.0d0 - 0.5d0 * ee1) ) &
23887                / (2.0d0 * fgb1)
23888        dPOLdR1 = dPOLdFGB1 * dFGBdR1
23889 !       dPOLdR1 = 0.0d0
23890 !       dPOLdOM1 = 0.0d0
23891        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
23892                * (2.0d0 - 0.5d0 * ee1) ) &
23893                / (2.0d0 * fgb1)
23894
23895        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
23896        dPOLdOM2 = 0.0
23897        DO k = 1, 3
23898         erhead(k) = Rhead_distance(k)/Rhead
23899         erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
23900        END DO
23901
23902        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23903        erdxj = scalar( erhead(1), dC_norm(1,j) )
23904        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
23905 !       bat=0.0d0
23906        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
23907        facd1 = d1i * vbld_inv(i+nres)
23908        facd2 = d1j * vbld_inv(j)
23909 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23910
23911        DO k = 1, 3
23912         hawk = (erhead_tail(k,1) + &
23913         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
23914 !        facd1=0.0d0
23915 !        facd2=0.0d0
23916 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
23917 !                pom,(erhead_tail(k,1))
23918
23919 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
23920         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23921         gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
23922                    - dGCLdR * pom &
23923                    - dPOLdR1 *  (erhead_tail(k,1))
23924 !     &             - dGLJdR * pom
23925
23926         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
23927 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
23928 !                   + dGCLdR * pom  &
23929 !                   + dPOLdR1 * (erhead_tail(k,1))
23930 !     &             + dGLJdR * pom
23931
23932
23933         gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
23934                   - dGCLdR * erhead(k) &
23935                   - dPOLdR1 * erhead_tail(k,1)
23936 !     &             - dGLJdR * erhead(k)
23937
23938         gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
23939                   + (dGCLdR * erhead(k)  &
23940                   + dPOLdR1 * erhead_tail(k,1))/2.0
23941         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
23942                   + (dGCLdR * erhead(k)  &
23943                   + dPOLdR1 * erhead_tail(k,1))/2.0
23944
23945 !     &             + dGLJdR * erhead(k)
23946 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
23947
23948        END DO
23949 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
23950        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
23951         "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
23952        escpho=escpho+evdwij+epol+Fcav+ECL
23953        call sc_grad_scpho
23954          enddo
23955
23956       enddo
23957
23958       return
23959       end subroutine eprot_sc_phosphate
23960       SUBROUTINE sc_grad_scpho
23961       use calc_data
23962
23963        real (kind=8) :: dcosom1(3),dcosom2(3)
23964        eom1  =    &
23965               eps2der * eps2rt_om1   &
23966             - 2.0D0 * alf1 * eps3der &
23967             + sigder * sigsq_om1     &
23968             + dCAVdOM1               &
23969             + dGCLdOM1               &
23970             + dPOLdOM1
23971
23972        eom2  =  &
23973               eps2der * eps2rt_om2   &
23974             + 2.0D0 * alf2 * eps3der &
23975             + sigder * sigsq_om2     &
23976             + dCAVdOM2               &
23977             + dGCLdOM2               &
23978             + dPOLdOM2
23979
23980        eom12 =    &
23981               evdwij  * eps1_om12     &
23982             + eps2der * eps2rt_om12   &
23983             - 2.0D0 * alf12 * eps3der &
23984             + sigder *sigsq_om12      &
23985             + dCAVdOM12               &
23986             + dGCLdOM12
23987 !        om12=0.0
23988 !        eom12=0.0
23989 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23990 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
23991 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23992 !                 *dsci_inv*2.0
23993 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23994 !               gg(1),gg(2),"rozne"
23995        DO k = 1, 3
23996         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
23997         dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
23998         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23999         gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
24000                  + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
24001                  *dscj_inv*2.0 &
24002                  - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24003         gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
24004                  - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
24005                  *dscj_inv*2.0 &
24006                  + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24007         gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
24008                  + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
24009                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24010
24011 !         print *,eom12,eom2,om12,om2
24012 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24013 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24014 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
24015 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24016 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24017         gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
24018        END DO
24019        RETURN
24020       END SUBROUTINE sc_grad_scpho
24021       subroutine eprot_pep_phosphate(epeppho)
24022       use calc_data
24023 !      implicit real*8 (a-h,o-z)
24024 !      include 'DIMENSIONS'
24025 !      include 'COMMON.GEO'
24026 !      include 'COMMON.VAR'
24027 !      include 'COMMON.LOCAL'
24028 !      include 'COMMON.CHAIN'
24029 !      include 'COMMON.DERIV'
24030 !      include 'COMMON.NAMES'
24031 !      include 'COMMON.INTERACT'
24032 !      include 'COMMON.IOUNITS'
24033 !      include 'COMMON.CALC'
24034 !      include 'COMMON.CONTROL'
24035 !      include 'COMMON.SBRIDGE'
24036       logical :: lprn
24037 !el local variables
24038       integer :: iint,itypi,itypi1,itypj,subchap
24039       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24040       real(kind=8) :: evdw,sig0ij
24041       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24042                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24043                     sslipi,sslipj,faclip
24044       integer :: ii
24045       real(kind=8) :: fracinbuf
24046        real (kind=8) :: epeppho
24047        real (kind=8),dimension(4):: ener
24048        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24049        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24050         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
24051         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24052         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
24053         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24054         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24055         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
24056        real(kind=8),dimension(3,2)::chead,erhead_tail
24057        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24058        integer troll
24059        real (kind=8) :: dcosom1(3),dcosom2(3)
24060        epeppho=0.0d0
24061 !       do i=1,nres_molec(1)
24062         do i=ibond_start,ibond_end
24063         if (itype(i,1).eq.ntyp1_molec(1)) cycle
24064         itypi  = itype(i,1)
24065         dsci_inv = vbld_inv(i+1)/2.0
24066         dxi    = dc_norm(1,i)
24067         dyi    = dc_norm(2,i)
24068         dzi    = dc_norm(3,i)
24069         xi=(c(1,i)+c(1,i+1))/2.0
24070         yi=(c(2,i)+c(2,i+1))/2.0
24071         zi=(c(3,i)+c(3,i+1))/2.0
24072         xi=mod(xi,boxxsize)
24073          if (xi.lt.0) xi=xi+boxxsize
24074         yi=mod(yi,boxysize)
24075          if (yi.lt.0) yi=yi+boxysize
24076         zi=mod(zi,boxzsize)
24077          if (zi.lt.0) zi=zi+boxzsize
24078          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
24079            itypj= itype(j,2)
24080            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
24081             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
24082            xj=(c(1,j)+c(1,j+1))/2.0
24083            yj=(c(2,j)+c(2,j+1))/2.0
24084            zj=(c(3,j)+c(3,j+1))/2.0
24085            xj=dmod(xj,boxxsize)
24086            if (xj.lt.0) xj=xj+boxxsize
24087            yj=dmod(yj,boxysize)
24088            if (yj.lt.0) yj=yj+boxysize
24089            zj=dmod(zj,boxzsize)
24090            if (zj.lt.0) zj=zj+boxzsize
24091           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24092           xj_safe=xj
24093           yj_safe=yj
24094           zj_safe=zj
24095           subchap=0
24096           do xshift=-1,1
24097           do yshift=-1,1
24098           do zshift=-1,1
24099           xj=xj_safe+xshift*boxxsize
24100           yj=yj_safe+yshift*boxysize
24101           zj=zj_safe+zshift*boxzsize
24102           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24103           if(dist_temp.lt.dist_init) then
24104             dist_init=dist_temp
24105             xj_temp=xj
24106             yj_temp=yj
24107             zj_temp=zj
24108             subchap=1
24109           endif
24110           enddo
24111           enddo
24112           enddo
24113           if (subchap.eq.1) then
24114           xj=xj_temp-xi
24115           yj=yj_temp-yi
24116           zj=zj_temp-zi
24117           else
24118           xj=xj_safe-xi
24119           yj=yj_safe-yi
24120           zj=zj_safe-zi
24121           endif
24122           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24123           rij  = dsqrt(rrij)
24124           dxj = dc_norm( 1,j )
24125           dyj = dc_norm( 2,j )
24126           dzj = dc_norm( 3,j )
24127           dscj_inv = vbld_inv(j+1)/2.0
24128 ! Gay-berne var's
24129           sig0ij = sigma_peppho
24130 !          chi1=0.0d0
24131 !          chi2=0.0d0
24132           chi12  = chi1 * chi2
24133 !          chip1=0.0d0
24134 !          chip2=0.0d0
24135           chip12 = chip1 * chip2
24136 !          chis1 = 0.0d0
24137 !          chis2 = 0.0d0
24138           chis12 = chis1 * chis2
24139           sig1 = sigmap1_peppho
24140           sig2 = sigmap2_peppho
24141 !       write (*,*) "sig1 = ", sig1
24142 !       write (*,*) "sig1 = ", sig1
24143 !       write (*,*) "sig2 = ", sig2
24144 ! alpha factors from Fcav/Gcav
24145           alf1   = 0.0d0
24146           alf2   = 0.0d0
24147           alf12  = 0.0d0
24148           b1 = alphasur_peppho(1)
24149 !          b1=0.0d0
24150           b2 = alphasur_peppho(2)
24151           b3 = alphasur_peppho(3)
24152           b4 = alphasur_peppho(4)
24153           CALL sc_angular
24154        sqom1=om1*om1
24155        evdwij = 0.0d0
24156        ECL = 0.0d0
24157        Elj = 0.0d0
24158        Equad = 0.0d0
24159        Epol = 0.0d0
24160        Fcav=0.0d0
24161        eheadtail = 0.0d0
24162        dGCLdR=0.0d0
24163        dGCLdOM1 = 0.0d0
24164        dGCLdOM2 = 0.0d0
24165        dGCLdOM12 = 0.0d0
24166        dPOLdOM1 = 0.0d0
24167        dPOLdOM2 = 0.0d0
24168           Fcav = 0.0d0
24169           dFdR = 0.0d0
24170           dCAVdOM1  = 0.0d0
24171           dCAVdOM2  = 0.0d0
24172           dCAVdOM12 = 0.0d0
24173           rij_shift = rij
24174           fac       = rij_shift**expon
24175           c1        = fac  * fac * aa_peppho
24176 !          c1        = 0.0d0
24177           c2        = fac  * bb_peppho
24178 !          c2        = 0.0d0
24179           evdwij    =  c1 + c2
24180 ! Now cavity....................
24181        eagle = dsqrt(1.0/rij_shift)
24182        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
24183           bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
24184           botsq = bot * bot
24185           Fcav = top / bot
24186           dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
24187           dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
24188           dFdR = ((dtop * bot - top * dbot) / botsq)
24189        w1        = wqdip_peppho(1)
24190        w2        = wqdip_peppho(2)
24191 !       w1=0.0d0
24192 !       w2=0.0d0
24193 !       pis       = sig0head_scbase(itypi,itypj)
24194 !       eps_head   = epshead_scbase(itypi,itypj)
24195 !c!-------------------------------------------------------------------
24196
24197 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24198 !c!     &        +dhead(1,1,itypi,itypj))**2))
24199 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24200 !c!     &        +dhead(2,1,itypi,itypj))**2))
24201
24202 !c!-------------------------------------------------------------------
24203 !c! ecl
24204        sparrow  = w1  *  om1
24205        hawk     = w2 *  (1.0d0 - sqom1)
24206        Ecl = sparrow * rij_shift**2.0d0 &
24207            - hawk    * rij_shift**4.0d0
24208 !c!-------------------------------------------------------------------
24209 !c! derivative of ecl is Gcl
24210 !c! dF/dr part
24211 !       rij_shift=5.0
24212        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
24213                 + 4.0d0 * hawk    * rij_shift**5.0d0
24214 !c! dF/dom1
24215        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
24216 !c! dF/dom2
24217        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
24218        eom1  =    dGCLdOM1+dGCLdOM2
24219        eom2  =    0.0
24220
24221           fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
24222 !          fac=0.0
24223           gg(1) =  fac*xj*rij
24224           gg(2) =  fac*yj*rij
24225           gg(3) =  fac*zj*rij
24226          do k=1,3
24227          gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
24228          gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
24229          gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
24230          gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
24231          gg(k)=0.0
24232          enddo
24233
24234       DO k = 1, 3
24235         dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
24236         dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
24237         gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
24238         gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
24239 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24240         gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
24241 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24242         gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
24243                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24244         gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
24245                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24246         enddo
24247        epeppho=epeppho+evdwij+Fcav+ECL
24248 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
24249        enddo
24250        enddo
24251       end subroutine eprot_pep_phosphate
24252 !!!!!!!!!!!!!!!!-------------------------------------------------------------
24253       subroutine emomo(evdw)
24254       use calc_data
24255       use comm_momo
24256 !      implicit real*8 (a-h,o-z)
24257 !      include 'DIMENSIONS'
24258 !      include 'COMMON.GEO'
24259 !      include 'COMMON.VAR'
24260 !      include 'COMMON.LOCAL'
24261 !      include 'COMMON.CHAIN'
24262 !      include 'COMMON.DERIV'
24263 !      include 'COMMON.NAMES'
24264 !      include 'COMMON.INTERACT'
24265 !      include 'COMMON.IOUNITS'
24266 !      include 'COMMON.CALC'
24267 !      include 'COMMON.CONTROL'
24268 !      include 'COMMON.SBRIDGE'
24269       logical :: lprn
24270 !el local variables
24271       integer :: iint,itypi1,subchap,isel
24272       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
24273       real(kind=8) :: evdw
24274       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24275                     dist_temp, dist_init,ssgradlipi,ssgradlipj, &
24276                     sslipi,sslipj,faclip,alpha_sco
24277       integer :: ii
24278       real(kind=8) :: fracinbuf
24279        real (kind=8) :: escpho
24280        real (kind=8),dimension(4):: ener
24281        real(kind=8) :: b1,b2,egb
24282        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
24283         Lambf,&
24284         Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
24285         dFdOM2,dFdL,dFdOM12,&
24286         federmaus,&
24287         d1i,d1j
24288 !       real(kind=8),dimension(3,2)::erhead_tail
24289 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
24290        real(kind=8) ::  facd4, adler, Fgb, facd3
24291        integer troll,jj,istate
24292        real (kind=8) :: dcosom1(3),dcosom2(3)
24293        eps_out=80.0d0
24294        sss_ele_cut=1.0d0
24295 !       print *,"EVDW KURW",evdw,nres
24296       do i=iatsc_s,iatsc_e
24297 !        print *,"I am in EVDW",i
24298         itypi=iabs(itype(i,1))
24299 !        if (i.ne.47) cycle
24300         if (itypi.eq.ntyp1) cycle
24301         itypi1=iabs(itype(i+1,1))
24302         xi=c(1,nres+i)
24303         yi=c(2,nres+i)
24304         zi=c(3,nres+i)
24305           xi=dmod(xi,boxxsize)
24306           if (xi.lt.0) xi=xi+boxxsize
24307           yi=dmod(yi,boxysize)
24308           if (yi.lt.0) yi=yi+boxysize
24309           zi=dmod(zi,boxzsize)
24310           if (zi.lt.0) zi=zi+boxzsize
24311
24312        if ((zi.gt.bordlipbot)  &
24313         .and.(zi.lt.bordliptop)) then
24314 !C the energy transfer exist
24315         if (zi.lt.buflipbot) then
24316 !C what fraction I am in
24317          fracinbuf=1.0d0-  &
24318               ((zi-bordlipbot)/lipbufthick)
24319 !C lipbufthick is thickenes of lipid buffore
24320          sslipi=sscalelip(fracinbuf)
24321          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
24322         elseif (zi.gt.bufliptop) then
24323          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
24324          sslipi=sscalelip(fracinbuf)
24325          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
24326         else
24327          sslipi=1.0d0
24328          ssgradlipi=0.0
24329         endif
24330        else
24331          sslipi=0.0d0
24332          ssgradlipi=0.0
24333        endif
24334 !       print *, sslipi,ssgradlipi
24335         dxi=dc_norm(1,nres+i)
24336         dyi=dc_norm(2,nres+i)
24337         dzi=dc_norm(3,nres+i)
24338 !        dsci_inv=dsc_inv(itypi)
24339         dsci_inv=vbld_inv(i+nres)
24340 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
24341 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
24342 !
24343 ! Calculate SC interaction energy.
24344 !
24345         do iint=1,nint_gr(i)
24346           do j=istart(i,iint),iend(i,iint)
24347 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
24348             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
24349               call dyn_ssbond_ene(i,j,evdwij)
24350               evdw=evdw+evdwij
24351               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
24352                               'evdw',i,j,evdwij,' ss'
24353 !              if (energy_dec) write (iout,*) &
24354 !                              'evdw',i,j,evdwij,' ss'
24355              do k=j+1,iend(i,iint)
24356 !C search over all next residues
24357               if (dyn_ss_mask(k)) then
24358 !C check if they are cysteins
24359 !C              write(iout,*) 'k=',k
24360
24361 !c              write(iout,*) "PRZED TRI", evdwij
24362 !               evdwij_przed_tri=evdwij
24363               call triple_ssbond_ene(i,j,k,evdwij)
24364 !c               if(evdwij_przed_tri.ne.evdwij) then
24365 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
24366 !c               endif
24367
24368 !c              write(iout,*) "PO TRI", evdwij
24369 !C call the energy function that removes the artifical triple disulfide
24370 !C bond the soubroutine is located in ssMD.F
24371               evdw=evdw+evdwij
24372               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
24373                             'evdw',i,j,evdwij,'tss'
24374               endif!dyn_ss_mask(k)
24375              enddo! k
24376             ELSE
24377 !el            ind=ind+1
24378             itypj=iabs(itype(j,1))
24379             if (itypj.eq.ntyp1) cycle
24380              CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
24381
24382 !             if (j.ne.78) cycle
24383 !            dscj_inv=dsc_inv(itypj)
24384             dscj_inv=vbld_inv(j+nres)
24385            xj=c(1,j+nres)
24386            yj=c(2,j+nres)
24387            zj=c(3,j+nres)
24388            xj=dmod(xj,boxxsize)
24389            if (xj.lt.0) xj=xj+boxxsize
24390            yj=dmod(yj,boxysize)
24391            if (yj.lt.0) yj=yj+boxysize
24392            zj=dmod(zj,boxzsize)
24393            if (zj.lt.0) zj=zj+boxzsize
24394           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24395           xj_safe=xj
24396           yj_safe=yj
24397           zj_safe=zj
24398           subchap=0
24399
24400           do xshift=-1,1
24401           do yshift=-1,1
24402           do zshift=-1,1
24403           xj=xj_safe+xshift*boxxsize
24404           yj=yj_safe+yshift*boxysize
24405           zj=zj_safe+zshift*boxzsize
24406           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24407           if(dist_temp.lt.dist_init) then
24408             dist_init=dist_temp
24409             xj_temp=xj
24410             yj_temp=yj
24411             zj_temp=zj
24412             subchap=1
24413           endif
24414           enddo
24415           enddo
24416           enddo
24417           if (subchap.eq.1) then
24418           xj=xj_temp-xi
24419           yj=yj_temp-yi
24420           zj=zj_temp-zi
24421           else
24422           xj=xj_safe-xi
24423           yj=yj_safe-yi
24424           zj=zj_safe-zi
24425           endif
24426           dxj = dc_norm( 1, nres+j )
24427           dyj = dc_norm( 2, nres+j )
24428           dzj = dc_norm( 3, nres+j )
24429 !          print *,i,j,itypi,itypj
24430 !          d1i=0.0d0
24431 !          d1j=0.0d0
24432 !          BetaT = 1.0d0 / (298.0d0 * Rb)
24433 ! Gay-berne var's
24434 !1!          sig0ij = sigma_scsc( itypi,itypj )
24435 !          chi1=0.0d0
24436 !          chi2=0.0d0
24437 !          chip1=0.0d0
24438 !          chip2=0.0d0
24439 ! not used by momo potential, but needed by sc_angular which is shared
24440 ! by all energy_potential subroutines
24441           alf1   = 0.0d0
24442           alf2   = 0.0d0
24443           alf12  = 0.0d0
24444           a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
24445 !       a12sq = a12sq * a12sq
24446 ! charge of amino acid itypi is...
24447           chis1 = chis(itypi,itypj)
24448           chis2 = chis(itypj,itypi)
24449           chis12 = chis1 * chis2
24450           sig1 = sigmap1(itypi,itypj)
24451           sig2 = sigmap2(itypi,itypj)
24452 !       write (*,*) "sig1 = ", sig1
24453 !          chis1=0.0
24454 !          chis2=0.0
24455 !                    chis12 = chis1 * chis2
24456 !          sig1=0.0
24457 !          sig2=0.0
24458 !       write (*,*) "sig2 = ", sig2
24459 ! alpha factors from Fcav/Gcav
24460           b1cav = alphasur(1,itypi,itypj)
24461 !          b1cav=0.0d0
24462           b2cav = alphasur(2,itypi,itypj)
24463           b3cav = alphasur(3,itypi,itypj)
24464           b4cav = alphasur(4,itypi,itypj)
24465 ! used to determine whether we want to do quadrupole calculations
24466        eps_in = epsintab(itypi,itypj)
24467        if (eps_in.eq.0.0) eps_in=1.0
24468
24469        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24470        Rtail = 0.0d0
24471 !       dtail(1,itypi,itypj)=0.0
24472 !       dtail(2,itypi,itypj)=0.0
24473
24474        DO k = 1, 3
24475         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
24476         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
24477        END DO
24478 !c! tail distances will be themselves usefull elswhere
24479 !c1 (in Gcav, for example)
24480        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
24481        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
24482        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
24483        Rtail = dsqrt( &
24484           (Rtail_distance(1)*Rtail_distance(1)) &
24485         + (Rtail_distance(2)*Rtail_distance(2)) &
24486         + (Rtail_distance(3)*Rtail_distance(3)))
24487
24488 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24489 !-------------------------------------------------------------------
24490 ! tail location and distance calculations
24491        d1 = dhead(1, 1, itypi, itypj)
24492        d2 = dhead(2, 1, itypi, itypj)
24493
24494        DO k = 1,3
24495 ! location of polar head is computed by taking hydrophobic centre
24496 ! and moving by a d1 * dc_norm vector
24497 ! see unres publications for very informative images
24498         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
24499         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
24500 ! distance
24501 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24502 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24503         Rhead_distance(k) = chead(k,2) - chead(k,1)
24504        END DO
24505 ! pitagoras (root of sum of squares)
24506        Rhead = dsqrt( &
24507           (Rhead_distance(1)*Rhead_distance(1)) &
24508         + (Rhead_distance(2)*Rhead_distance(2)) &
24509         + (Rhead_distance(3)*Rhead_distance(3)))
24510 !-------------------------------------------------------------------
24511 ! zero everything that should be zero'ed
24512        evdwij = 0.0d0
24513        ECL = 0.0d0
24514        Elj = 0.0d0
24515        Equad = 0.0d0
24516        Epol = 0.0d0
24517        Fcav=0.0d0
24518        eheadtail = 0.0d0
24519        dGCLdOM1 = 0.0d0
24520        dGCLdOM2 = 0.0d0
24521        dGCLdOM12 = 0.0d0
24522        dPOLdOM1 = 0.0d0
24523        dPOLdOM2 = 0.0d0
24524           Fcav = 0.0d0
24525           dFdR = 0.0d0
24526           dCAVdOM1  = 0.0d0
24527           dCAVdOM2  = 0.0d0
24528           dCAVdOM12 = 0.0d0
24529           dscj_inv = vbld_inv(j+nres)
24530 !          print *,i,j,dscj_inv,dsci_inv
24531 ! rij holds 1/(distance of Calpha atoms)
24532           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24533           rij  = dsqrt(rrij)
24534 !----------------------------
24535           CALL sc_angular
24536 ! this should be in elgrad_init but om's are calculated by sc_angular
24537 ! which in turn is used by older potentials
24538 ! om = omega, sqom = om^2
24539           sqom1  = om1 * om1
24540           sqom2  = om2 * om2
24541           sqom12 = om12 * om12
24542
24543 ! now we calculate EGB - Gey-Berne
24544 ! It will be summed up in evdwij and saved in evdw
24545           sigsq     = 1.0D0  / sigsq
24546           sig       = sig0ij * dsqrt(sigsq)
24547 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24548           rij_shift = Rtail - sig + sig0ij
24549           IF (rij_shift.le.0.0D0) THEN
24550            evdw = 1.0D20
24551            RETURN
24552           END IF
24553           sigder = -sig * sigsq
24554           rij_shift = 1.0D0 / rij_shift
24555           fac       = rij_shift**expon
24556           c1        = fac  * fac * aa_aq(itypi,itypj)
24557 !          print *,"ADAM",aa_aq(itypi,itypj)
24558
24559 !          c1        = 0.0d0
24560           c2        = fac  * bb_aq(itypi,itypj)
24561 !          c2        = 0.0d0
24562           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24563           eps2der   = eps3rt * evdwij
24564           eps3der   = eps2rt * evdwij
24565 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24566           evdwij    = eps2rt * eps3rt * evdwij
24567 !#ifdef TSCSC
24568 !          IF (bb_aq(itypi,itypj).gt.0) THEN
24569 !           evdw_p = evdw_p + evdwij
24570 !          ELSE
24571 !           evdw_m = evdw_m + evdwij
24572 !          END IF
24573 !#else
24574           evdw = evdw  &
24575               + evdwij
24576 !#endif
24577
24578           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24579           fac    = -expon * (c1 + evdwij) * rij_shift
24580           sigder = fac * sigder
24581 !          fac    = rij * fac
24582 ! Calculate distance derivative
24583           gg(1) =  fac
24584           gg(2) =  fac
24585           gg(3) =  fac
24586 !          if (b2.gt.0.0) then
24587           fac = chis1 * sqom1 + chis2 * sqom2 &
24588           - 2.0d0 * chis12 * om1 * om2 * om12
24589 ! we will use pom later in Gcav, so dont mess with it!
24590           pom = 1.0d0 - chis1 * chis2 * sqom12
24591           Lambf = (1.0d0 - (fac / pom))
24592 !          print *,"fac,pom",fac,pom,Lambf
24593           Lambf = dsqrt(Lambf)
24594           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24595 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
24596 !       write (*,*) "sparrow = ", sparrow
24597           Chif = Rtail * sparrow
24598 !           print *,"rij,sparrow",rij , sparrow
24599           ChiLambf = Chif * Lambf
24600           eagle = dsqrt(ChiLambf)
24601           bat = ChiLambf ** 11.0d0
24602           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
24603           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
24604           botsq = bot * bot
24605 !          print *,top,bot,"bot,top",ChiLambf,Chif
24606           Fcav = top / bot
24607
24608        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
24609        dbot = 12.0d0 * b4cav * bat * Lambf
24610        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24611
24612           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
24613           dbot = 12.0d0 * b4cav * bat * Chif
24614           eagle = Lambf * pom
24615           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24616           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24617           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24618               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24619
24620           dFdL = ((dtop * bot - top * dbot) / botsq)
24621 !       dFdL = 0.0d0
24622           dCAVdOM1  = dFdL * ( dFdOM1 )
24623           dCAVdOM2  = dFdL * ( dFdOM2 )
24624           dCAVdOM12 = dFdL * ( dFdOM12 )
24625
24626        DO k= 1, 3
24627         ertail(k) = Rtail_distance(k)/Rtail
24628        END DO
24629        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
24630        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
24631        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
24632        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24633        DO k = 1, 3
24634 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24635 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24636         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24637         gvdwx(k,i) = gvdwx(k,i) &
24638                   - (( dFdR + gg(k) ) * pom)
24639 !c!     &             - ( dFdR * pom )
24640         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24641         gvdwx(k,j) = gvdwx(k,j)   &
24642                   + (( dFdR + gg(k) ) * pom)
24643 !c!     &             + ( dFdR * pom )
24644
24645         gvdwc(k,i) = gvdwc(k,i)  &
24646                   - (( dFdR + gg(k) ) * ertail(k))
24647 !c!     &             - ( dFdR * ertail(k))
24648
24649         gvdwc(k,j) = gvdwc(k,j) &
24650                   + (( dFdR + gg(k) ) * ertail(k))
24651 !c!     &             + ( dFdR * ertail(k))
24652
24653         gg(k) = 0.0d0
24654 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24655 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24656       END DO
24657
24658
24659 !c! Compute head-head and head-tail energies for each state
24660
24661           isel = iabs(Qi) + iabs(Qj)
24662 !          isel=0
24663           IF (isel.eq.0) THEN
24664 !c! No charges - do nothing
24665            eheadtail = 0.0d0
24666
24667           ELSE IF (isel.eq.4) THEN
24668 !c! Calculate dipole-dipole interactions
24669            CALL edd(ecl)
24670            eheadtail = ECL
24671 !           eheadtail = 0.0d0
24672
24673           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
24674 !c! Charge-nonpolar interactions
24675            CALL eqn(epol)
24676            eheadtail = epol
24677 !           eheadtail = 0.0d0
24678
24679           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
24680 !c! Nonpolar-charge interactions
24681            CALL enq(epol)
24682            eheadtail = epol
24683 !           eheadtail = 0.0d0
24684
24685           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
24686 !c! Charge-dipole interactions
24687            CALL eqd(ecl, elj, epol)
24688            eheadtail = ECL + elj + epol
24689 !           eheadtail = 0.0d0
24690
24691           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
24692 !c! Dipole-charge interactions
24693            CALL edq(ecl, elj, epol)
24694           eheadtail = ECL + elj + epol
24695 !           eheadtail = 0.0d0
24696
24697           ELSE IF ((isel.eq.2.and.   &
24698                iabs(Qi).eq.1).and.  &
24699                nstate(itypi,itypj).eq.1) THEN
24700 !c! Same charge-charge interaction ( +/+ or -/- )
24701            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
24702            eheadtail = ECL + Egb + Epol + Fisocav + Elj
24703 !           eheadtail = 0.0d0
24704
24705           ELSE IF ((isel.eq.2.and.  &
24706                iabs(Qi).eq.1).and. &
24707                nstate(itypi,itypj).ne.1) THEN
24708 !c! Different charge-charge interaction ( +/- or -/+ )
24709            CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
24710           END IF
24711        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
24712       evdw = evdw  + Fcav + eheadtail
24713
24714        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
24715         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
24716         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
24717         Equad,evdwij+Fcav+eheadtail,evdw
24718 !       evdw = evdw  + Fcav  + eheadtail
24719
24720         iF (nstate(itypi,itypj).eq.1) THEN
24721         CALL sc_grad
24722        END IF
24723 !c!-------------------------------------------------------------------
24724 !c! NAPISY KONCOWE
24725          END DO   ! j
24726         END DO    ! iint
24727        END DO     ! i
24728 !c      write (iout,*) "Number of loop steps in EGB:",ind
24729 !c      energy_dec=.false.
24730 !              print *,"EVDW KURW",evdw,nres
24731
24732        RETURN
24733       END SUBROUTINE emomo
24734 !C------------------------------------------------------------------------------------
24735       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
24736       use calc_data
24737       use comm_momo
24738        real (kind=8) ::  facd3, facd4, federmaus, adler,&
24739          Ecl,Egb,Epol,Fisocav,Elj,Fgb
24740 !       integer :: k
24741 !c! Epol and Gpol analytical parameters
24742        alphapol1 = alphapol(itypi,itypj)
24743        alphapol2 = alphapol(itypj,itypi)
24744 !c! Fisocav and Gisocav analytical parameters
24745        al1  = alphiso(1,itypi,itypj)
24746        al2  = alphiso(2,itypi,itypj)
24747        al3  = alphiso(3,itypi,itypj)
24748        al4  = alphiso(4,itypi,itypj)
24749        csig = (1.0d0  &
24750            / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
24751            + sigiso2(itypi,itypj)**2.0d0))
24752 !c!
24753        pis  = sig0head(itypi,itypj)
24754        eps_head = epshead(itypi,itypj)
24755        Rhead_sq = Rhead * Rhead
24756 !c! R1 - distance between head of ith side chain and tail of jth sidechain
24757 !c! R2 - distance between head of jth side chain and tail of ith sidechain
24758        R1 = 0.0d0
24759        R2 = 0.0d0
24760        DO k = 1, 3
24761 !c! Calculate head-to-tail distances needed by Epol
24762         R1=R1+(ctail(k,2)-chead(k,1))**2
24763         R2=R2+(chead(k,2)-ctail(k,1))**2
24764        END DO
24765 !c! Pitagoras
24766        R1 = dsqrt(R1)
24767        R2 = dsqrt(R2)
24768
24769 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24770 !c!     &        +dhead(1,1,itypi,itypj))**2))
24771 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24772 !c!     &        +dhead(2,1,itypi,itypj))**2))
24773
24774 !c!-------------------------------------------------------------------
24775 !c! Coulomb electrostatic interaction
24776        Ecl = (332.0d0 * Qij) / Rhead
24777 !c! derivative of Ecl is Gcl...
24778        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
24779        dGCLdOM1 = 0.0d0
24780        dGCLdOM2 = 0.0d0
24781        dGCLdOM12 = 0.0d0
24782        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
24783        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
24784        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
24785 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
24786 !c! Derivative of Egb is Ggb...
24787        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
24788        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
24789        dGGBdR = dGGBdFGB * dFGBdR
24790 !c!-------------------------------------------------------------------
24791 !c! Fisocav - isotropic cavity creation term
24792 !c! or "how much energy it costs to put charged head in water"
24793        pom = Rhead * csig
24794        top = al1 * (dsqrt(pom) + al2 * pom - al3)
24795        bot = (1.0d0 + al4 * pom**12.0d0)
24796        botsq = bot * bot
24797        FisoCav = top / bot
24798 !      write (*,*) "Rhead = ",Rhead
24799 !      write (*,*) "csig = ",csig
24800 !      write (*,*) "pom = ",pom
24801 !      write (*,*) "al1 = ",al1
24802 !      write (*,*) "al2 = ",al2
24803 !      write (*,*) "al3 = ",al3
24804 !      write (*,*) "al4 = ",al4
24805 !        write (*,*) "top = ",top
24806 !        write (*,*) "bot = ",bot
24807 !c! Derivative of Fisocav is GCV...
24808        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
24809        dbot = 12.0d0 * al4 * pom ** 11.0d0
24810        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
24811 !c!-------------------------------------------------------------------
24812 !c! Epol
24813 !c! Polarization energy - charged heads polarize hydrophobic "neck"
24814        MomoFac1 = (1.0d0 - chi1 * sqom2)
24815        MomoFac2 = (1.0d0 - chi2 * sqom1)
24816        RR1  = ( R1 * R1 ) / MomoFac1
24817        RR2  = ( R2 * R2 ) / MomoFac2
24818        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24819        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
24820        fgb1 = sqrt( RR1 + a12sq * ee1 )
24821        fgb2 = sqrt( RR2 + a12sq * ee2 )
24822        epol = 332.0d0 * eps_inout_fac * ( &
24823       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
24824 !c!       epol = 0.0d0
24825        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
24826                / (fgb1 ** 5.0d0)
24827        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
24828                / (fgb2 ** 5.0d0)
24829        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
24830              / ( 2.0d0 * fgb1 )
24831        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
24832              / ( 2.0d0 * fgb2 )
24833        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
24834                 * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
24835        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
24836                 * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
24837        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24838 !c!       dPOLdR1 = 0.0d0
24839        dPOLdR2 = dPOLdFGB2 * dFGBdR2
24840 !c!       dPOLdR2 = 0.0d0
24841        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
24842 !c!       dPOLdOM1 = 0.0d0
24843        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
24844 !c!       dPOLdOM2 = 0.0d0
24845 !c!-------------------------------------------------------------------
24846 !c! Elj
24847 !c! Lennard-Jones 6-12 interaction between heads
24848        pom = (pis / Rhead)**6.0d0
24849        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
24850 !c! derivative of Elj is Glj
24851        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
24852              +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
24853 !c!-------------------------------------------------------------------
24854 !c! Return the results
24855 !c! These things do the dRdX derivatives, that is
24856 !c! allow us to change what we see from function that changes with
24857 !c! distance to function that changes with LOCATION (of the interaction
24858 !c! site)
24859        DO k = 1, 3
24860         erhead(k) = Rhead_distance(k)/Rhead
24861         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
24862         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
24863        END DO
24864
24865        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24866        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24867        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24868        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
24869        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
24870        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
24871        facd1 = d1 * vbld_inv(i+nres)
24872        facd2 = d2 * vbld_inv(j+nres)
24873        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
24874        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24875
24876 !c! Now we add appropriate partial derivatives (one in each dimension)
24877        DO k = 1, 3
24878         hawk   = (erhead_tail(k,1) + &
24879         facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
24880         condor = (erhead_tail(k,2) + &
24881         facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
24882
24883         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24884         gvdwx(k,i) = gvdwx(k,i) &
24885                   - dGCLdR * pom&
24886                   - dGGBdR * pom&
24887                   - dGCVdR * pom&
24888                   - dPOLdR1 * hawk&
24889                   - dPOLdR2 * (erhead_tail(k,2)&
24890       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
24891                   - dGLJdR * pom
24892
24893         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24894         gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
24895                    + dGGBdR * pom+ dGCVdR * pom&
24896                   + dPOLdR1 * (erhead_tail(k,1)&
24897       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
24898                   + dPOLdR2 * condor + dGLJdR * pom
24899
24900         gvdwc(k,i) = gvdwc(k,i)  &
24901                   - dGCLdR * erhead(k)&
24902                   - dGGBdR * erhead(k)&
24903                   - dGCVdR * erhead(k)&
24904                   - dPOLdR1 * erhead_tail(k,1)&
24905                   - dPOLdR2 * erhead_tail(k,2)&
24906                   - dGLJdR * erhead(k)
24907
24908         gvdwc(k,j) = gvdwc(k,j)         &
24909                   + dGCLdR * erhead(k) &
24910                   + dGGBdR * erhead(k) &
24911                   + dGCVdR * erhead(k) &
24912                   + dPOLdR1 * erhead_tail(k,1) &
24913                   + dPOLdR2 * erhead_tail(k,2)&
24914                   + dGLJdR * erhead(k)
24915
24916        END DO
24917        RETURN
24918       END SUBROUTINE eqq
24919 !c!-------------------------------------------------------------------
24920       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
24921       use comm_momo
24922       use calc_data
24923
24924        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
24925        double precision ener(4)
24926        double precision dcosom1(3),dcosom2(3)
24927 !c! used in Epol derivatives
24928        double precision facd3, facd4
24929        double precision federmaus, adler
24930        integer istate,ii,jj
24931        real (kind=8) :: Fgb
24932 !       print *,"CALLING EQUAD"
24933 !c! Epol and Gpol analytical parameters
24934        alphapol1 = alphapol(itypi,itypj)
24935        alphapol2 = alphapol(itypj,itypi)
24936 !c! Fisocav and Gisocav analytical parameters
24937        al1  = alphiso(1,itypi,itypj)
24938        al2  = alphiso(2,itypi,itypj)
24939        al3  = alphiso(3,itypi,itypj)
24940        al4  = alphiso(4,itypi,itypj)
24941        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
24942             + sigiso2(itypi,itypj)**2.0d0))
24943 !c!
24944        w1   = wqdip(1,itypi,itypj)
24945        w2   = wqdip(2,itypi,itypj)
24946        pis  = sig0head(itypi,itypj)
24947        eps_head = epshead(itypi,itypj)
24948 !c! First things first:
24949 !c! We need to do sc_grad's job with GB and Fcav
24950        eom1  = eps2der * eps2rt_om1 &
24951              - 2.0D0 * alf1 * eps3der&
24952              + sigder * sigsq_om1&
24953              + dCAVdOM1
24954        eom2  = eps2der * eps2rt_om2 &
24955              + 2.0D0 * alf2 * eps3der&
24956              + sigder * sigsq_om2&
24957              + dCAVdOM2
24958        eom12 =  evdwij  * eps1_om12 &
24959              + eps2der * eps2rt_om12 &
24960              - 2.0D0 * alf12 * eps3der&
24961              + sigder *sigsq_om12&
24962              + dCAVdOM12
24963 !c! now some magical transformations to project gradient into
24964 !c! three cartesian vectors
24965        DO k = 1, 3
24966         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24967         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24968         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24969 !c! this acts on hydrophobic center of interaction
24970         gvdwx(k,i)= gvdwx(k,i) - gg(k) &
24971                   + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
24972                   + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24973         gvdwx(k,j)= gvdwx(k,j) + gg(k) &
24974                   + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
24975                   + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24976 !c! this acts on Calpha
24977         gvdwc(k,i)=gvdwc(k,i)-gg(k)
24978         gvdwc(k,j)=gvdwc(k,j)+gg(k)
24979        END DO
24980 !c! sc_grad is done, now we will compute
24981        eheadtail = 0.0d0
24982        eom1 = 0.0d0
24983        eom2 = 0.0d0
24984        eom12 = 0.0d0
24985        DO istate = 1, nstate(itypi,itypj)
24986 !c*************************************************************
24987         IF (istate.ne.1) THEN
24988          IF (istate.lt.3) THEN
24989           ii = 1
24990          ELSE
24991           ii = 2
24992          END IF
24993         jj = istate/ii
24994         d1 = dhead(1,ii,itypi,itypj)
24995         d2 = dhead(2,jj,itypi,itypj)
24996         DO k = 1,3
24997          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
24998          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
24999          Rhead_distance(k) = chead(k,2) - chead(k,1)
25000         END DO
25001 !c! pitagoras (root of sum of squares)
25002         Rhead = dsqrt( &
25003                (Rhead_distance(1)*Rhead_distance(1))  &
25004              + (Rhead_distance(2)*Rhead_distance(2))  &
25005              + (Rhead_distance(3)*Rhead_distance(3)))
25006         END IF
25007         Rhead_sq = Rhead * Rhead
25008
25009 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25010 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25011         R1 = 0.0d0
25012         R2 = 0.0d0
25013         DO k = 1, 3
25014 !c! Calculate head-to-tail distances
25015          R1=R1+(ctail(k,2)-chead(k,1))**2
25016          R2=R2+(chead(k,2)-ctail(k,1))**2
25017         END DO
25018 !c! Pitagoras
25019         R1 = dsqrt(R1)
25020         R2 = dsqrt(R2)
25021         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
25022 !c!        Ecl = 0.0d0
25023 !c!        write (*,*) "Ecl = ", Ecl
25024 !c! derivative of Ecl is Gcl...
25025         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
25026 !c!        dGCLdR = 0.0d0
25027         dGCLdOM1 = 0.0d0
25028         dGCLdOM2 = 0.0d0
25029         dGCLdOM12 = 0.0d0
25030 !c!-------------------------------------------------------------------
25031 !c! Generalised Born Solvent Polarization
25032         ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25033         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25034         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
25035 !c!        Egb = 0.0d0
25036 !c!      write (*,*) "a1*a2 = ", a12sq
25037 !c!      write (*,*) "Rhead = ", Rhead
25038 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
25039 !c!      write (*,*) "ee = ", ee
25040 !c!      write (*,*) "Fgb = ", Fgb
25041 !c!      write (*,*) "fac = ", eps_inout_fac
25042 !c!      write (*,*) "Qij = ", Qij
25043 !c!      write (*,*) "Egb = ", Egb
25044 !c! Derivative of Egb is Ggb...
25045 !c! dFGBdR is used by Quad's later...
25046         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
25047         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
25048                / ( 2.0d0 * Fgb )
25049         dGGBdR = dGGBdFGB * dFGBdR
25050 !c!        dGGBdR = 0.0d0
25051 !c!-------------------------------------------------------------------
25052 !c! Fisocav - isotropic cavity creation term
25053         pom = Rhead * csig
25054         top = al1 * (dsqrt(pom) + al2 * pom - al3)
25055         bot = (1.0d0 + al4 * pom**12.0d0)
25056         botsq = bot * bot
25057         FisoCav = top / bot
25058         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
25059         dbot = 12.0d0 * al4 * pom ** 11.0d0
25060         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
25061 !c!        dGCVdR = 0.0d0
25062 !c!-------------------------------------------------------------------
25063 !c! Polarization energy
25064 !c! Epol
25065         MomoFac1 = (1.0d0 - chi1 * sqom2)
25066         MomoFac2 = (1.0d0 - chi2 * sqom1)
25067         RR1  = ( R1 * R1 ) / MomoFac1
25068         RR2  = ( R2 * R2 ) / MomoFac2
25069         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25070         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
25071         fgb1 = sqrt( RR1 + a12sq * ee1 )
25072         fgb2 = sqrt( RR2 + a12sq * ee2 )
25073         epol = 332.0d0 * eps_inout_fac * (&
25074         (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
25075 !c!        epol = 0.0d0
25076 !c! derivative of Epol is Gpol...
25077         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
25078                   / (fgb1 ** 5.0d0)
25079         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
25080                   / (fgb2 ** 5.0d0)
25081         dFGBdR1 = ( (R1 / MomoFac1) &
25082                 * ( 2.0d0 - (0.5d0 * ee1) ) )&
25083                 / ( 2.0d0 * fgb1 )
25084         dFGBdR2 = ( (R2 / MomoFac2) &
25085                 * ( 2.0d0 - (0.5d0 * ee2) ) ) &
25086                 / ( 2.0d0 * fgb2 )
25087         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25088                  * ( 2.0d0 - 0.5d0 * ee1) ) &
25089                  / ( 2.0d0 * fgb1 )
25090         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
25091                  * ( 2.0d0 - 0.5d0 * ee2) ) &
25092                  / ( 2.0d0 * fgb2 )
25093         dPOLdR1 = dPOLdFGB1 * dFGBdR1
25094 !c!        dPOLdR1 = 0.0d0
25095         dPOLdR2 = dPOLdFGB2 * dFGBdR2
25096 !c!        dPOLdR2 = 0.0d0
25097         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25098 !c!        dPOLdOM1 = 0.0d0
25099         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25100         pom = (pis / Rhead)**6.0d0
25101         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25102 !c!        Elj = 0.0d0
25103 !c! derivative of Elj is Glj
25104         dGLJdR = 4.0d0 * eps_head &
25105             * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
25106             +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25107 !c!        dGLJdR = 0.0d0
25108 !c!-------------------------------------------------------------------
25109 !c! Equad
25110        IF (Wqd.ne.0.0d0) THEN
25111         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
25112              - 37.5d0  * ( sqom1 + sqom2 ) &
25113              + 157.5d0 * ( sqom1 * sqom2 ) &
25114              - 45.0d0  * om1*om2*om12
25115         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
25116         Equad = fac * Beta1
25117 !c!        Equad = 0.0d0
25118 !c! derivative of Equad...
25119         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
25120 !c!        dQUADdR = 0.0d0
25121         dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
25122 !c!        dQUADdOM1 = 0.0d0
25123         dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
25124 !c!        dQUADdOM2 = 0.0d0
25125         dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
25126        ELSE
25127          Beta1 = 0.0d0
25128          Equad = 0.0d0
25129         END IF
25130 !c!-------------------------------------------------------------------
25131 !c! Return the results
25132 !c! Angular stuff
25133         eom1 = dPOLdOM1 + dQUADdOM1
25134         eom2 = dPOLdOM2 + dQUADdOM2
25135         eom12 = dQUADdOM12
25136 !c! now some magical transformations to project gradient into
25137 !c! three cartesian vectors
25138         DO k = 1, 3
25139          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25140          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25141          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
25142         END DO
25143 !c! Radial stuff
25144         DO k = 1, 3
25145          erhead(k) = Rhead_distance(k)/Rhead
25146          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25147          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25148         END DO
25149         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25150         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25151         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25152         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25153         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25154         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25155         facd1 = d1 * vbld_inv(i+nres)
25156         facd2 = d2 * vbld_inv(j+nres)
25157         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25158         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25159         DO k = 1, 3
25160          hawk   = erhead_tail(k,1) + &
25161          facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
25162          condor = erhead_tail(k,2) + &
25163          facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
25164
25165          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25166 !c! this acts on hydrophobic center of interaction
25167          gheadtail(k,1,1) = gheadtail(k,1,1) &
25168                          - dGCLdR * pom &
25169                          - dGGBdR * pom &
25170                          - dGCVdR * pom &
25171                          - dPOLdR1 * hawk &
25172                          - dPOLdR2 * (erhead_tail(k,2) &
25173       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
25174                          - dGLJdR * pom &
25175                          - dQUADdR * pom&
25176                          - tuna(k) &
25177                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
25178                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25179
25180          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25181 !c! this acts on hydrophobic center of interaction
25182          gheadtail(k,2,1) = gheadtail(k,2,1)  &
25183                          + dGCLdR * pom      &
25184                          + dGGBdR * pom      &
25185                          + dGCVdR * pom      &
25186                          + dPOLdR1 * (erhead_tail(k,1) &
25187       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
25188                          + dPOLdR2 * condor &
25189                          + dGLJdR * pom &
25190                          + dQUADdR * pom &
25191                          + tuna(k) &
25192                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25193                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25194
25195 !c! this acts on Calpha
25196          gheadtail(k,3,1) = gheadtail(k,3,1)  &
25197                          - dGCLdR * erhead(k)&
25198                          - dGGBdR * erhead(k)&
25199                          - dGCVdR * erhead(k)&
25200                          - dPOLdR1 * erhead_tail(k,1)&
25201                          - dPOLdR2 * erhead_tail(k,2)&
25202                          - dGLJdR * erhead(k) &
25203                          - dQUADdR * erhead(k)&
25204                          - tuna(k)
25205 !c! this acts on Calpha
25206          gheadtail(k,4,1) = gheadtail(k,4,1)   &
25207                           + dGCLdR * erhead(k) &
25208                           + dGGBdR * erhead(k) &
25209                           + dGCVdR * erhead(k) &
25210                           + dPOLdR1 * erhead_tail(k,1) &
25211                           + dPOLdR2 * erhead_tail(k,2) &
25212                           + dGLJdR * erhead(k) &
25213                           + dQUADdR * erhead(k)&
25214                           + tuna(k)
25215         END DO
25216         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
25217         eheadtail = eheadtail &
25218                   + wstate(istate, itypi, itypj) &
25219                   * dexp(-betaT * ener(istate))
25220 !c! foreach cartesian dimension
25221         DO k = 1, 3
25222 !c! foreach of two gvdwx and gvdwc
25223          DO l = 1, 4
25224           gheadtail(k,l,2) = gheadtail(k,l,2)  &
25225                            + wstate( istate, itypi, itypj ) &
25226                            * dexp(-betaT * ener(istate)) &
25227                            * gheadtail(k,l,1)
25228           gheadtail(k,l,1) = 0.0d0
25229          END DO
25230         END DO
25231        END DO
25232 !c! Here ended the gigantic DO istate = 1, 4, which starts
25233 !c! at the beggining of the subroutine
25234
25235        DO k = 1, 3
25236         DO l = 1, 4
25237          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
25238         END DO
25239         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
25240         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
25241         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
25242         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
25243         DO l = 1, 4
25244          gheadtail(k,l,1) = 0.0d0
25245          gheadtail(k,l,2) = 0.0d0
25246         END DO
25247        END DO
25248        eheadtail = (-dlog(eheadtail)) / betaT
25249        dPOLdOM1 = 0.0d0
25250        dPOLdOM2 = 0.0d0
25251        dQUADdOM1 = 0.0d0
25252        dQUADdOM2 = 0.0d0
25253        dQUADdOM12 = 0.0d0
25254        RETURN
25255       END SUBROUTINE energy_quad
25256 !!-----------------------------------------------------------
25257       SUBROUTINE eqn(Epol)
25258       use comm_momo
25259       use calc_data
25260
25261       double precision  facd4, federmaus,epol
25262       alphapol1 = alphapol(itypi,itypj)
25263 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25264        R1 = 0.0d0
25265        DO k = 1, 3
25266 !c! Calculate head-to-tail distances
25267         R1=R1+(ctail(k,2)-chead(k,1))**2
25268        END DO
25269 !c! Pitagoras
25270        R1 = dsqrt(R1)
25271
25272 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25273 !c!     &        +dhead(1,1,itypi,itypj))**2))
25274 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25275 !c!     &        +dhead(2,1,itypi,itypj))**2))
25276 !c--------------------------------------------------------------------
25277 !c Polarization energy
25278 !c Epol
25279        MomoFac1 = (1.0d0 - chi1 * sqom2)
25280        RR1  = R1 * R1 / MomoFac1
25281        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25282        fgb1 = sqrt( RR1 + a12sq * ee1)
25283        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
25284        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
25285                / (fgb1 ** 5.0d0)
25286        dFGBdR1 = ( (R1 / MomoFac1) &
25287               * ( 2.0d0 - (0.5d0 * ee1) ) ) &
25288               / ( 2.0d0 * fgb1 )
25289        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25290                 * (2.0d0 - 0.5d0 * ee1) ) &
25291                 / (2.0d0 * fgb1)
25292        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25293 !c!       dPOLdR1 = 0.0d0
25294        dPOLdOM1 = 0.0d0
25295        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25296        DO k = 1, 3
25297         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25298        END DO
25299        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25300        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25301        facd1 = d1 * vbld_inv(i+nres)
25302        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25303
25304        DO k = 1, 3
25305         hawk = (erhead_tail(k,1) + &
25306         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
25307
25308         gvdwx(k,i) = gvdwx(k,i) &
25309                    - dPOLdR1 * hawk
25310         gvdwx(k,j) = gvdwx(k,j) &
25311                    + dPOLdR1 * (erhead_tail(k,1) &
25312        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
25313
25314         gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
25315         gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
25316
25317        END DO
25318        RETURN
25319       END SUBROUTINE eqn
25320       SUBROUTINE enq(Epol)
25321       use calc_data
25322       use comm_momo
25323        double precision facd3, adler,epol
25324        alphapol2 = alphapol(itypj,itypi)
25325 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25326        R2 = 0.0d0
25327        DO k = 1, 3
25328 !c! Calculate head-to-tail distances
25329         R2=R2+(chead(k,2)-ctail(k,1))**2
25330        END DO
25331 !c! Pitagoras
25332        R2 = dsqrt(R2)
25333
25334 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25335 !c!     &        +dhead(1,1,itypi,itypj))**2))
25336 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25337 !c!     &        +dhead(2,1,itypi,itypj))**2))
25338 !c------------------------------------------------------------------------
25339 !c Polarization energy
25340        MomoFac2 = (1.0d0 - chi2 * sqom1)
25341        RR2  = R2 * R2 / MomoFac2
25342        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
25343        fgb2 = sqrt(RR2  + a12sq * ee2)
25344        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
25345        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
25346                 / (fgb2 ** 5.0d0)
25347        dFGBdR2 = ( (R2 / MomoFac2)  &
25348               * ( 2.0d0 - (0.5d0 * ee2) ) ) &
25349               / (2.0d0 * fgb2)
25350        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
25351                 * (2.0d0 - 0.5d0 * ee2) ) &
25352                 / (2.0d0 * fgb2)
25353        dPOLdR2 = dPOLdFGB2 * dFGBdR2
25354 !c!       dPOLdR2 = 0.0d0
25355        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25356 !c!       dPOLdOM1 = 0.0d0
25357        dPOLdOM2 = 0.0d0
25358 !c!-------------------------------------------------------------------
25359 !c! Return the results
25360 !c! (See comments in Eqq)
25361        DO k = 1, 3
25362         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25363        END DO
25364        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25365        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25366        facd2 = d2 * vbld_inv(j+nres)
25367        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25368        DO k = 1, 3
25369         condor = (erhead_tail(k,2) &
25370        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
25371
25372         gvdwx(k,i) = gvdwx(k,i) &
25373                    - dPOLdR2 * (erhead_tail(k,2) &
25374        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
25375         gvdwx(k,j) = gvdwx(k,j)   &
25376                    + dPOLdR2 * condor
25377
25378         gvdwc(k,i) = gvdwc(k,i) &
25379                    - dPOLdR2 * erhead_tail(k,2)
25380         gvdwc(k,j) = gvdwc(k,j) &
25381                    + dPOLdR2 * erhead_tail(k,2)
25382
25383        END DO
25384       RETURN
25385       END SUBROUTINE enq
25386       SUBROUTINE eqd(Ecl,Elj,Epol)
25387       use calc_data
25388       use comm_momo
25389        double precision  facd4, federmaus,ecl,elj,epol
25390        alphapol1 = alphapol(itypi,itypj)
25391        w1        = wqdip(1,itypi,itypj)
25392        w2        = wqdip(2,itypi,itypj)
25393        pis       = sig0head(itypi,itypj)
25394        eps_head   = epshead(itypi,itypj)
25395 !c!-------------------------------------------------------------------
25396 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25397        R1 = 0.0d0
25398        DO k = 1, 3
25399 !c! Calculate head-to-tail distances
25400         R1=R1+(ctail(k,2)-chead(k,1))**2
25401        END DO
25402 !c! Pitagoras
25403        R1 = dsqrt(R1)
25404
25405 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25406 !c!     &        +dhead(1,1,itypi,itypj))**2))
25407 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25408 !c!     &        +dhead(2,1,itypi,itypj))**2))
25409
25410 !c!-------------------------------------------------------------------
25411 !c! ecl
25412        sparrow  = w1 * Qi * om1
25413        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
25414        Ecl = sparrow / Rhead**2.0d0 &
25415            - hawk    / Rhead**4.0d0
25416        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
25417                  + 4.0d0 * hawk    / Rhead**5.0d0
25418 !c! dF/dom1
25419        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
25420 !c! dF/dom2
25421        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
25422 !c--------------------------------------------------------------------
25423 !c Polarization energy
25424 !c Epol
25425        MomoFac1 = (1.0d0 - chi1 * sqom2)
25426        RR1  = R1 * R1 / MomoFac1
25427        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25428        fgb1 = sqrt( RR1 + a12sq * ee1)
25429        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
25430 !c!       epol = 0.0d0
25431 !c!------------------------------------------------------------------
25432 !c! derivative of Epol is Gpol...
25433        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
25434                / (fgb1 ** 5.0d0)
25435        dFGBdR1 = ( (R1 / MomoFac1)  &
25436              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
25437              / ( 2.0d0 * fgb1 )
25438        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25439                * (2.0d0 - 0.5d0 * ee1) ) &
25440                / (2.0d0 * fgb1)
25441        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25442 !c!       dPOLdR1 = 0.0d0
25443        dPOLdOM1 = 0.0d0
25444        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25445 !c!       dPOLdOM2 = 0.0d0
25446 !c!-------------------------------------------------------------------
25447 !c! Elj
25448        pom = (pis / Rhead)**6.0d0
25449        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25450 !c! derivative of Elj is Glj
25451        dGLJdR = 4.0d0 * eps_head &
25452           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
25453           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25454        DO k = 1, 3
25455         erhead(k) = Rhead_distance(k)/Rhead
25456         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25457        END DO
25458
25459        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25460        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25461        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25462        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25463        facd1 = d1 * vbld_inv(i+nres)
25464        facd2 = d2 * vbld_inv(j+nres)
25465        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25466
25467        DO k = 1, 3
25468         hawk = (erhead_tail(k,1) +  &
25469         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
25470
25471         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25472         gvdwx(k,i) = gvdwx(k,i)  &
25473                    - dGCLdR * pom&
25474                    - dPOLdR1 * hawk &
25475                    - dGLJdR * pom
25476
25477         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25478         gvdwx(k,j) = gvdwx(k,j)    &
25479                    + dGCLdR * pom  &
25480                    + dPOLdR1 * (erhead_tail(k,1) &
25481        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
25482                    + dGLJdR * pom
25483
25484
25485         gvdwc(k,i) = gvdwc(k,i)          &
25486                    - dGCLdR * erhead(k)  &
25487                    - dPOLdR1 * erhead_tail(k,1) &
25488                    - dGLJdR * erhead(k)
25489
25490         gvdwc(k,j) = gvdwc(k,j)          &
25491                    + dGCLdR * erhead(k)  &
25492                    + dPOLdR1 * erhead_tail(k,1) &
25493                    + dGLJdR * erhead(k)
25494
25495        END DO
25496        RETURN
25497       END SUBROUTINE eqd
25498       SUBROUTINE edq(Ecl,Elj,Epol)
25499 !       IMPLICIT NONE
25500        use comm_momo
25501       use calc_data
25502
25503       double precision  facd3, adler,ecl,elj,epol
25504        alphapol2 = alphapol(itypj,itypi)
25505        w1        = wqdip(1,itypi,itypj)
25506        w2        = wqdip(2,itypi,itypj)
25507        pis       = sig0head(itypi,itypj)
25508        eps_head  = epshead(itypi,itypj)
25509 !c!-------------------------------------------------------------------
25510 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25511        R2 = 0.0d0
25512        DO k = 1, 3
25513 !c! Calculate head-to-tail distances
25514         R2=R2+(chead(k,2)-ctail(k,1))**2
25515        END DO
25516 !c! Pitagoras
25517        R2 = dsqrt(R2)
25518
25519 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25520 !c!     &        +dhead(1,1,itypi,itypj))**2))
25521 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25522 !c!     &        +dhead(2,1,itypi,itypj))**2))
25523
25524
25525 !c!-------------------------------------------------------------------
25526 !c! ecl
25527        sparrow  = w1 * Qi * om1
25528        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
25529        ECL = sparrow / Rhead**2.0d0 &
25530            - hawk    / Rhead**4.0d0
25531 !c!-------------------------------------------------------------------
25532 !c! derivative of ecl is Gcl
25533 !c! dF/dr part
25534        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
25535                  + 4.0d0 * hawk    / Rhead**5.0d0
25536 !c! dF/dom1
25537        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
25538 !c! dF/dom2
25539        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
25540 !c--------------------------------------------------------------------
25541 !c Polarization energy
25542 !c Epol
25543        MomoFac2 = (1.0d0 - chi2 * sqom1)
25544        RR2  = R2 * R2 / MomoFac2
25545        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
25546        fgb2 = sqrt(RR2  + a12sq * ee2)
25547        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
25548        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
25549                / (fgb2 ** 5.0d0)
25550        dFGBdR2 = ( (R2 / MomoFac2)  &
25551                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
25552                / (2.0d0 * fgb2)
25553        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
25554                 * (2.0d0 - 0.5d0 * ee2) ) &
25555                 / (2.0d0 * fgb2)
25556        dPOLdR2 = dPOLdFGB2 * dFGBdR2
25557 !c!       dPOLdR2 = 0.0d0
25558        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25559 !c!       dPOLdOM1 = 0.0d0
25560        dPOLdOM2 = 0.0d0
25561 !c!-------------------------------------------------------------------
25562 !c! Elj
25563        pom = (pis / Rhead)**6.0d0
25564        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25565 !c! derivative of Elj is Glj
25566        dGLJdR = 4.0d0 * eps_head &
25567            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
25568            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25569 !c!-------------------------------------------------------------------
25570 !c! Return the results
25571 !c! (see comments in Eqq)
25572        DO k = 1, 3
25573         erhead(k) = Rhead_distance(k)/Rhead
25574         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25575        END DO
25576        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25577        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25578        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25579        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25580        facd1 = d1 * vbld_inv(i+nres)
25581        facd2 = d2 * vbld_inv(j+nres)
25582        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25583        DO k = 1, 3
25584         condor = (erhead_tail(k,2) &
25585        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
25586
25587         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25588         gvdwx(k,i) = gvdwx(k,i) &
25589                   - dGCLdR * pom &
25590                   - dPOLdR2 * (erhead_tail(k,2) &
25591        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
25592                   - dGLJdR * pom
25593
25594         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25595         gvdwx(k,j) = gvdwx(k,j) &
25596                   + dGCLdR * pom &
25597                   + dPOLdR2 * condor &
25598                   + dGLJdR * pom
25599
25600
25601         gvdwc(k,i) = gvdwc(k,i) &
25602                   - dGCLdR * erhead(k) &
25603                   - dPOLdR2 * erhead_tail(k,2) &
25604                   - dGLJdR * erhead(k)
25605
25606         gvdwc(k,j) = gvdwc(k,j) &
25607                   + dGCLdR * erhead(k) &
25608                   + dPOLdR2 * erhead_tail(k,2) &
25609                   + dGLJdR * erhead(k)
25610
25611        END DO
25612        RETURN
25613       END SUBROUTINE edq
25614       SUBROUTINE edd(ECL)
25615 !       IMPLICIT NONE
25616        use comm_momo
25617       use calc_data
25618
25619        double precision ecl
25620 !c!       csig = sigiso(itypi,itypj)
25621        w1 = wqdip(1,itypi,itypj)
25622        w2 = wqdip(2,itypi,itypj)
25623 !c!-------------------------------------------------------------------
25624 !c! ECL
25625        fac = (om12 - 3.0d0 * om1 * om2)
25626        c1 = (w1 / (Rhead**3.0d0)) * fac
25627        c2 = (w2 / Rhead ** 6.0d0) &
25628           * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
25629        ECL = c1 - c2
25630 !c!       write (*,*) "w1 = ", w1
25631 !c!       write (*,*) "w2 = ", w2
25632 !c!       write (*,*) "om1 = ", om1
25633 !c!       write (*,*) "om2 = ", om2
25634 !c!       write (*,*) "om12 = ", om12
25635 !c!       write (*,*) "fac = ", fac
25636 !c!       write (*,*) "c1 = ", c1
25637 !c!       write (*,*) "c2 = ", c2
25638 !c!       write (*,*) "Ecl = ", Ecl
25639 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
25640 !c!       write (*,*) "c2_2 = ",
25641 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
25642 !c!-------------------------------------------------------------------
25643 !c! dervative of ECL is GCL...
25644 !c! dECL/dr
25645        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
25646        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
25647           * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
25648        dGCLdR = c1 - c2
25649 !c! dECL/dom1
25650        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
25651        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25652           * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
25653        dGCLdOM1 = c1 - c2
25654 !c! dECL/dom2
25655        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
25656        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25657           * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
25658        dGCLdOM2 = c1 - c2
25659 !c! dECL/dom12
25660        c1 = w1 / (Rhead ** 3.0d0)
25661        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
25662        dGCLdOM12 = c1 - c2
25663 !c!-------------------------------------------------------------------
25664 !c! Return the results
25665 !c! (see comments in Eqq)
25666        DO k= 1, 3
25667         erhead(k) = Rhead_distance(k)/Rhead
25668        END DO
25669        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25670        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25671        facd1 = d1 * vbld_inv(i+nres)
25672        facd2 = d2 * vbld_inv(j+nres)
25673        DO k = 1, 3
25674
25675         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25676         gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
25677         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25678         gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
25679
25680         gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
25681         gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
25682        END DO
25683        RETURN
25684       END SUBROUTINE edd
25685       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
25686 !       IMPLICIT NONE
25687        use comm_momo
25688       use calc_data
25689
25690        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
25691        eps_out=80.0d0
25692        itypi = itype(i,1)
25693        itypj = itype(j,1)
25694 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
25695 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
25696 !c!       t_bath = 300
25697 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
25698        Rb=0.001986d0
25699        BetaT = 1.0d0 / (298.0d0 * Rb)
25700 !c! Gay-berne var's
25701        sig0ij = sigma( itypi,itypj )
25702        chi1   = chi( itypi, itypj )
25703        chi2   = chi( itypj, itypi )
25704        chi12  = chi1 * chi2
25705        chip1  = chipp( itypi, itypj )
25706        chip2  = chipp( itypj, itypi )
25707        chip12 = chip1 * chip2
25708 !       chi1=0.0
25709 !       chi2=0.0
25710 !       chi12=0.0
25711 !       chip1=0.0
25712 !       chip2=0.0
25713 !       chip12=0.0
25714 !c! not used by momo potential, but needed by sc_angular which is shared
25715 !c! by all energy_potential subroutines
25716        alf1   = 0.0d0
25717        alf2   = 0.0d0
25718        alf12  = 0.0d0
25719 !c! location, location, location
25720 !       xj  = c( 1, nres+j ) - xi
25721 !       yj  = c( 2, nres+j ) - yi
25722 !       zj  = c( 3, nres+j ) - zi
25723        dxj = dc_norm( 1, nres+j )
25724        dyj = dc_norm( 2, nres+j )
25725        dzj = dc_norm( 3, nres+j )
25726 !c! distance from center of chain(?) to polar/charged head
25727 !c!       write (*,*) "istate = ", 1
25728 !c!       write (*,*) "ii = ", 1
25729 !c!       write (*,*) "jj = ", 1
25730        d1 = dhead(1, 1, itypi, itypj)
25731        d2 = dhead(2, 1, itypi, itypj)
25732 !c! ai*aj from Fgb
25733        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
25734 !c!       a12sq = a12sq * a12sq
25735 !c! charge of amino acid itypi is...
25736        Qi  = icharge(itypi)
25737        Qj  = icharge(itypj)
25738        Qij = Qi * Qj
25739 !c! chis1,2,12
25740        chis1 = chis(itypi,itypj)
25741        chis2 = chis(itypj,itypi)
25742        chis12 = chis1 * chis2
25743        sig1 = sigmap1(itypi,itypj)
25744        sig2 = sigmap2(itypi,itypj)
25745 !c!       write (*,*) "sig1 = ", sig1
25746 !c!       write (*,*) "sig2 = ", sig2
25747 !c! alpha factors from Fcav/Gcav
25748        b1cav = alphasur(1,itypi,itypj)
25749 !       b1cav=0.0
25750        b2cav = alphasur(2,itypi,itypj)
25751        b3cav = alphasur(3,itypi,itypj)
25752        b4cav = alphasur(4,itypi,itypj)
25753        wqd = wquad(itypi, itypj)
25754 !c! used by Fgb
25755        eps_in = epsintab(itypi,itypj)
25756        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25757 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
25758 !c!-------------------------------------------------------------------
25759 !c! tail location and distance calculations
25760        Rtail = 0.0d0
25761        DO k = 1, 3
25762         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
25763         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
25764        END DO
25765 !c! tail distances will be themselves usefull elswhere
25766 !c1 (in Gcav, for example)
25767        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
25768        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
25769        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
25770        Rtail = dsqrt(  &
25771           (Rtail_distance(1)*Rtail_distance(1))  &
25772         + (Rtail_distance(2)*Rtail_distance(2))  &
25773         + (Rtail_distance(3)*Rtail_distance(3)))
25774 !c!-------------------------------------------------------------------
25775 !c! Calculate location and distance between polar heads
25776 !c! distance between heads
25777 !c! for each one of our three dimensional space...
25778        d1 = dhead(1, 1, itypi, itypj)
25779        d2 = dhead(2, 1, itypi, itypj)
25780
25781        DO k = 1,3
25782 !c! location of polar head is computed by taking hydrophobic centre
25783 !c! and moving by a d1 * dc_norm vector
25784 !c! see unres publications for very informative images
25785         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25786         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25787 !c! distance
25788 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25789 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25790         Rhead_distance(k) = chead(k,2) - chead(k,1)
25791        END DO
25792 !c! pitagoras (root of sum of squares)
25793        Rhead = dsqrt(   &
25794           (Rhead_distance(1)*Rhead_distance(1)) &
25795         + (Rhead_distance(2)*Rhead_distance(2)) &
25796         + (Rhead_distance(3)*Rhead_distance(3)))
25797 !c!-------------------------------------------------------------------
25798 !c! zero everything that should be zero'ed
25799        Egb = 0.0d0
25800        ECL = 0.0d0
25801        Elj = 0.0d0
25802        Equad = 0.0d0
25803        Epol = 0.0d0
25804        eheadtail = 0.0d0
25805        dGCLdOM1 = 0.0d0
25806        dGCLdOM2 = 0.0d0
25807        dGCLdOM12 = 0.0d0
25808        dPOLdOM1 = 0.0d0
25809        dPOLdOM2 = 0.0d0
25810        RETURN
25811       END SUBROUTINE elgrad_init
25812       end module energy