source/unres/energy.F90

   1       module energy
   2 !-----------------------------------------------------------------------------
   3       use io_units
   4       use names
   5       use math
   6       use MPI_data
   7       use energy_data
   8       use control_data
   9       use geometry_data
  10       use geometry
  11 !
  12       implicit none
  13 !-----------------------------------------------------------------------------
  14 ! Max. number of contacts per residue
  15 !      integer :: maxconts
  16 !-----------------------------------------------------------------------------
  17 ! Max. number of derivatives of virtual-bond and side-chain vectors in theta
  18 ! or phi.
  19 !      integer :: maxdim
  20 !-----------------------------------------------------------------------------
  21 ! Max. number of SC contacts
  22 !      integer :: maxcont
  23 !-----------------------------------------------------------------------------
  24 ! Max. number of variables
  25       integer :: maxvar
  26 !-----------------------------------------------------------------------------
  27 ! Max number of torsional terms in SCCOR  in control_data
  28 !      integer,parameter :: maxterm_sccor=6
  29 !-----------------------------------------------------------------------------
  30 ! Maximum number of SC local term fitting function coefficiants
  31       integer,parameter :: maxsccoef=65
  32 ! Maximum number of local shielding effectors
  33 !      integer,parameter :: maxcontsshi=50
  34 !-----------------------------------------------------------------------------
  35 ! commom.calc common/calc/
  36 !-----------------------------------------------------------------------------
  37 ! commom.contacts
  38 !      common /contacts/
  39 ! Change 12/1/95 - common block CONTACTS1 included.
  40 !      common /contacts1/
  41
  42       integer,dimension(:),allocatable :: num_cont      !(maxres)
  43       integer,dimension(:,:),allocatable :: jcont      !(maxconts,maxres)
  44       real(kind=8),dimension(:,:),allocatable :: facont,ees0plist      !(maxconts,maxres)
  45       real(kind=8),dimension(:,:,:),allocatable :: gacont      !(3,maxconts,maxres)
  46       integer,dimension(:),allocatable :: ishield_list
  47       integer,dimension(:,:),allocatable ::  shield_list
  48       real(kind=8),dimension(:),allocatable :: enetube,enecavtube
  49 !
  50 ! 12/26/95 - H-bonding contacts
  51 !      common /contacts_hb/
  52       real(kind=8),dimension(:,:,:),allocatable :: gacontp_hb1,gacontp_hb2,&
  53        gacontp_hb3,gacontm_hb1,gacontm_hb2,gacontm_hb3,gacont_hbr,grij_hb_cont      !(3,maxconts,maxres)
  54       real(kind=8),dimension(:,:),allocatable :: facont_hb,ees0p,&
  55         ees0m,d_cont      !(maxconts,maxres)
  56       integer,dimension(:),allocatable :: num_cont_hb      !(maxres)
  57       integer,dimension(:,:),allocatable :: jcont_hb      !(maxconts,maxres)
  58 ! 9/23/99 Added improper rotation matrices and matrices of dipole-dipole
  59 !         interactions
  60 ! 7/25/08 commented out; not needed when cumulants used
  61 ! Interactions of pseudo-dipoles generated by loc-el interactions.
  62 !  common /dipint/
  63       real(kind=8),dimension(:,:,:),allocatable :: dip,&
  64          dipderg      !(4,maxconts,maxres)
  65       real(kind=8),dimension(:,:,:,:,:),allocatable :: dipderx !(3,5,4,maxconts,maxres)
  66 ! 10/30/99 Added other pre-computed vectors and matrices needed
  67 !          to calculate three - six-order el-loc correlation terms
  68 ! common /rotat/
  69       real(kind=8),dimension(:,:,:),allocatable :: Ug,Ugder,Ug2,Ug2der      !(2,2,maxres)
  70       real(kind=8),dimension(:,:),allocatable :: obrot,obrot2,obrot_der,&
  71        obrot2_der      !(2,maxres)
  72 !
  73 ! This common block contains vectors and matrices dependent on a single
  74 ! amino-acid residue.
  75 !      common /precomp1/
  76       real(kind=8),dimension(:,:),allocatable :: mu,muder,Ub2,Ub2der,&
  77        Ctobr,Ctobrder,Dtobr2,Dtobr2der      !(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_locbuf1(3*maxcontsshi*nres), &
 258       grad_shield_sidebuf1(3*maxcontsshi*nres), &
 259       grad_shield_locbuf2(3*maxcontsshi*nres), &
 260       grad_shield_sidebuf2(3*maxcontsshi*nres), &
 261       grad_shieldbuf1(3*nres), &
 262       grad_shieldbuf2(3*nres)
 263
 264        integer ishield_listbuf(-1:nres), &
 265        shield_listbuf(maxcontsshi,-1:nres),k,j,i,iii,impishi,mojint,jjj
 266
 267
 268 !      real(kind=8),  dimension(:),allocatable::  fac_shieldbuf
 269 !      real(kind=8), dimension(:,:,:),allocatable:: &
 270 !       grad_shield_locbuf,grad_shield_sidebuf
 271 !      real(kind=8), dimension(:,:),allocatable:: &
 272 !        grad_shieldbuf
 273 !       integer, dimension(:),allocatable:: &
 274 !       ishield_listbuf
 275 !       integer, dimension(:,:),allocatable::  shield_listbuf
 276 !       integer :: k,j,i
 277 !      if (.not.allocated(fac_shieldbuf)) then
 278 !          allocate(fac_shieldbuf(nres))
 279 !          allocate(grad_shield_locbuf(3,maxcontsshi,-1:nres))
 280 !          allocate(grad_shield_sidebuf(3,maxcontsshi,-1:nres))
 281 !          allocate(grad_shieldbuf(3,-1:nres))
 282 !          allocate(ishield_listbuf(nres))
 283 !          allocate(shield_listbuf(maxcontsshi,nres))
 284 !       endif
 285
 286 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 287 !     & " nfgtasks",nfgtasks
 288       if (nfgtasks.gt.1) then
 289         time00=MPI_Wtime()
 290 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 291         if (fg_rank.eq.0) then
 292           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 293 !          print *,"Processor",myrank," BROADCAST iorder"
 294 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 295 ! FG slaves as WEIGHTS array.
 296          ! weights_(1)=wsc
 297           weights_(2)=wscp
 298           weights_(3)=welec
 299           weights_(4)=wcorr
 300           weights_(5)=wcorr5
 301           weights_(6)=wcorr6
 302           weights_(7)=wel_loc
 303           weights_(8)=wturn3
 304           weights_(9)=wturn4
 305           weights_(10)=wturn6
 306           weights_(11)=wang
 307           weights_(12)=wscloc
 308           weights_(13)=wtor
 309           weights_(14)=wtor_d
 310           weights_(15)=wstrain
 311           weights_(16)=wvdwpp
 312           weights_(17)=wbond
 313           weights_(18)=scal14
 314           weights_(21)=wsccor
 315           weights_(26)=wvdwpp_nucl
 316           weights_(27)=welpp
 317           weights_(28)=wvdwpsb
 318           weights_(29)=welpsb
 319           weights_(30)=wvdwsb
 320           weights_(31)=welsb
 321           weights_(32)=wbond_nucl
 322           weights_(33)=wang_nucl
 323           weights_(34)=wsbloc
 324           weights_(35)=wtor_nucl
 325           weights_(36)=wtor_d_nucl
 326           weights_(37)=wcorr_nucl
 327           weights_(38)=wcorr3_nucl
 328           weights_(41)=wcatcat
 329           weights_(42)=wcatprot
 330           weights_(46)=wscbase
 331           weights_(47)=wscpho
 332           weights_(48)=wpeppho
 333 !          wcatcat= weights(41)
 334 !          wcatprot=weights(42)
 335
 336 ! FG Master broadcasts the WEIGHTS_ array
 337           call MPI_Bcast(weights_(1),n_ene,&
 338              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 339         else
 340 ! FG slaves receive the WEIGHTS array
 341           call MPI_Bcast(weights(1),n_ene,&
 342               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 343           wsc=weights(1)
 344           wscp=weights(2)
 345           welec=weights(3)
 346           wcorr=weights(4)
 347           wcorr5=weights(5)
 348           wcorr6=weights(6)
 349           wel_loc=weights(7)
 350           wturn3=weights(8)
 351           wturn4=weights(9)
 352           wturn6=weights(10)
 353           wang=weights(11)
 354           wscloc=weights(12)
 355           wtor=weights(13)
 356           wtor_d=weights(14)
 357           wstrain=weights(15)
 358           wvdwpp=weights(16)
 359           wbond=weights(17)
 360           scal14=weights(18)
 361           wsccor=weights(21)
 362           wvdwpp_nucl =weights(26)
 363           welpp  =weights(27)
 364           wvdwpsb=weights(28)
 365           welpsb =weights(29)
 366           wvdwsb =weights(30)
 367           welsb  =weights(31)
 368           wbond_nucl  =weights(32)
 369           wang_nucl   =weights(33)
 370           wsbloc =weights(34)
 371           wtor_nucl   =weights(35)
 372           wtor_d_nucl =weights(36)
 373           wcorr_nucl  =weights(37)
 374           wcorr3_nucl =weights(38)
 375           wcatcat= weights(41)
 376           wcatprot=weights(42)
 377           wscbase=weights(46)
 378           wscpho=weights(47)
 379           wpeppho=weights(48)
 380         endif
 381         time_Bcast=time_Bcast+MPI_Wtime()-time00
 382         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 383 !        call chainbuild_cart
 384       endif
 385 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 386 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 387 #else
 388 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 389 !        call int_from_cart1(.false.)
 390 !      endif
 391 #endif
 392 #ifdef TIMING
 393       time00=MPI_Wtime()
 394 #endif
 395 !
 396 ! Compute the side-chain and electrostatic interaction energy
 397 !        print *, "Before EVDW"
 398 !      goto (101,102,103,104,105,106) ipot
 399       select case(ipot)
 400 ! Lennard-Jones potential.
 401 !  101 call elj(evdw)
 402        case (1)
 403          call elj(evdw)
 404 !d    print '(a)','Exit ELJcall el'
 405 !      goto 107
 406 ! Lennard-Jones-Kihara potential (shifted).
 407 !  102 call eljk(evdw)
 408        case (2)
 409          call eljk(evdw)
 410 !      goto 107
 411 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 412 !  103 call ebp(evdw)
 413        case (3)
 414          call ebp(evdw)
 415 !      goto 107
 416 ! Gay-Berne potential (shifted LJ, angular dependence).
 417 !  104 call egb(evdw)
 418        case (4)
 419 !       print *,"MOMO",scelemode
 420         if (scelemode.eq.0) then
 421          call egb(evdw)
 422         else
 423          call emomo(evdw)
 424         endif
 425 !      goto 107
 426 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 427 !  105 call egbv(evdw)
 428        case (5)
 429          call egbv(evdw)
 430 !      goto 107
 431 ! Soft-sphere potential
 432 !  106 call e_softsphere(evdw)
 433        case (6)
 434          call e_softsphere(evdw)
 435 !
 436 ! Calculate electrostatic (H-bonding) energy of the main chain.
 437 !
 438 !  107 continue
 439        case default
 440          write(iout,*)"Wrong ipot"
 441 !         return
 442 !   50 continue
 443       end select
 444 !      continue
 445 !        print *,"after EGB"
 446 ! shielding effect
 447        if (shield_mode.eq.2) then
 448                  call set_shield_fac2
 449
 450       if (nfgtasks.gt.1) then
 451       grad_shield_sidebuf1(:)=0.0d0
 452       grad_shield_locbuf1(:)=0.0d0
 453       grad_shield_sidebuf2(:)=0.0d0
 454       grad_shield_locbuf2(:)=0.0d0
 455       grad_shieldbuf1(:)=0.0d0
 456       grad_shieldbuf2(:)=0.0d0
 457 !#define DEBUG
 458 #ifdef DEBUG
 459        write(iout,*) "befor reduce fac_shield reduce"
 460        do i=1,nres
 461         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 462         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 463        grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 464        enddo
 465 #endif
 466         iii=0
 467         jjj=0
 468         do i=1,nres
 469         ishield_listbuf(i)=0
 470         do k=1,3
 471         iii=iii+1
 472         grad_shieldbuf1(iii)=grad_shield(k,i)
 473         enddo
 474         enddo
 475         do i=1,nres
 476          do j=1,maxcontsshi
 477           do k=1,3
 478               jjj=jjj+1
 479               grad_shield_sidebuf1(jjj)=grad_shield_side(k,j,i)
 480               grad_shield_locbuf1(jjj)=grad_shield_loc(k,j,i)
 481            enddo
 482           enddo
 483          enddo
 484         call MPI_Allgatherv(fac_shield(ivec_start), &
 485         ivec_count(fg_rank1), &
 486         MPI_DOUBLE_PRECISION,fac_shieldbuf(1),ivec_count(0), &
 487         ivec_displ(0), &
 488         MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 489         call MPI_Allgatherv(shield_list(1,ivec_start), &
 490         ivec_count(fg_rank1), &
 491         MPI_I50,shield_listbuf(1,1),ivec_count(0), &
 492         ivec_displ(0), &
 493         MPI_I50,FG_COMM,IERROR)
 494 !        write(2,*) "After I50"
 495 !        call flush(iout)
 496         call MPI_Allgatherv(ishield_list(ivec_start), &
 497         ivec_count(fg_rank1), &
 498         MPI_INTEGER,ishield_listbuf(1),ivec_count(0), &
 499         ivec_displ(0), &
 500         MPI_INTEGER,FG_COMM,IERROR)
 501 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 502
 503 !        write(2,*) ivec_count(fg_rank1)*3,ivec_count(0)*3,ivec_displ(0)*3,3*ivec_start-2
 504 !        write (2,*) "before"
 505 !        write(2,*) grad_shieldbuf1
 506 !        call MPI_Allgatherv(grad_shieldbuf1(3*ivec_start-2), &
 507 !        ivec_count(fg_rank1)*3, &
 508 !        MPI_DOUBLE_PRECISION,grad_shieldbuf2(1),ivec_count(0), &
 509 !        ivec_count(0), &
 510 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 511         call MPI_Allreduce(grad_shieldbuf1(1),grad_shieldbuf2(1), &
 512         nres*3, &
 513         MPI_DOUBLE_PRECISION, &
 514         MPI_SUM, &
 515         FG_COMM,IERROR)
 516         call MPI_Allreduce(grad_shield_sidebuf1(1),grad_shield_sidebuf2(1), &
 517         nres*3*maxcontsshi, &
 518         MPI_DOUBLE_PRECISION, &
 519         MPI_SUM, &
 520         FG_COMM,IERROR)
 521
 522         call MPI_Allreduce(grad_shield_locbuf1(1),grad_shield_locbuf2(1), &
 523         nres*3*maxcontsshi, &
 524         MPI_DOUBLE_PRECISION, &
 525         MPI_SUM, &
 526         FG_COMM,IERROR)
 527
 528 !        write(2,*) "after"
 529 !        write(2,*) grad_shieldbuf2
 530
 531 !        call MPI_Allgatherv(grad_shield_sidebuf1(3*maxcontsshi*ivec_start-2), &
 532 !        ivec_count(fg_rank1)*3*maxcontsshi, &
 533 !        MPI_DOUBLE_PRECISION,grad_shield_sidebuf2(1),ivec_count(0)*3*maxcontsshi,&
 534 !        ivec_displ(0)*3*maxcontsshi, &
 535 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 536 !        write(2,*) "After grad_shield_side"
 537 !        call flush(iout)
 538 !        call MPI_Allgatherv(grad_shield_locbuf1(3*maxcontsshi*ivec_start-2), &
 539 !        ivec_count(fg_rank1)*3*maxcontsshi, &
 540 !        MPI_DOUBLE_PRECISION,grad_shield_locbuf2(1),ivec_count(0)*3*maxcontsshi, &
 541 !        ivec_displ(0)*3*maxcontsshi, &
 542 !        MPI_DOUBLE_PRECISION,FG_COMM,IERROR)
 543 !        write(2,*) "After MPI_SHI"
 544 !        call flush(iout)
 545         iii=0
 546         jjj=0
 547         do i=1,nres
 548          fac_shield(i)=fac_shieldbuf(i)
 549          ishield_list(i)=ishield_listbuf(i)
 550 !         write(iout,*) i,fac_shield(i)
 551          do j=1,3
 552          iii=iii+1
 553          grad_shield(j,i)=grad_shieldbuf2(iii)
 554          enddo !j
 555          do j=1,ishield_list(i)
 556 !          write (iout,*) "ishild", ishield_list(i),i
 557            shield_list(j,i)=shield_listbuf(j,i)
 558           enddo
 559           do j=1,maxcontsshi
 560           do k=1,3
 561            jjj=jjj+1
 562           grad_shield_loc(k,j,i)=grad_shield_locbuf2(jjj)
 563           grad_shield_side(k,j,i)=grad_shield_sidebuf2(jjj)
 564           enddo !k
 565         enddo !j
 566        enddo !i
 567        endif
 568 #ifdef DEBUG
 569        write(iout,*) "after reduce fac_shield reduce"
 570        do i=1,nres
 571         write(2,*) "fac",itype(i,1),fac_shield(i),grad_shield(1,i)
 572         write(2,*) "list", shield_list(1,i),ishield_list(i), &
 573         grad_shield_side(1,1,i),grad_shield_loc(1,1,i)
 574        enddo
 575 #endif
 576 #undef DEBUG
 577        endif
 578
 579
 580
 581 !       print *,"AFTER EGB",ipot,evdw
 582 !mc
 583 !mc Sep-06: egb takes care of dynamic ss bonds too
 584 !mc
 585 !      if (dyn_ss) call dyn_set_nss
 586 !      print *,"Processor",myrank," computed USCSC"
 587 #ifdef TIMING
 588       time01=MPI_Wtime()
 589 #endif
 590       call vec_and_deriv
 591 #ifdef TIMING
 592       time_vec=time_vec+MPI_Wtime()-time01
 593 #endif
 594
 595
 596
 597
 598 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 599       if (ipot.lt.6) then
 600 #ifdef SPLITELE
 601 !         print *,"after ipot if", ipot
 602          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 603              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 604              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 605              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 606 #else
 607          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 608              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 609              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 610              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 611 #endif
 612             write(iout,*),"just befor eelec call"
 613             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 614 !         write (iout,*) "ELEC calc"
 615          else
 616             ees=0.0d0
 617             evdw1=0.0d0
 618             eel_loc=0.0d0
 619             eello_turn3=0.0d0
 620             eello_turn4=0.0d0
 621          endif
 622       else
 623 !        write (iout,*) "Soft-spheer ELEC potential"
 624         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 625          eello_turn4)
 626       endif
 627 !      print *,"Processor",myrank," computed UELEC"
 628 !
 629 ! Calculate excluded-volume interaction energy between peptide groups
 630 ! and side chains.
 631 !
 632 !       write(iout,*) "in etotal calc exc;luded",ipot
 633
 634       if (ipot.lt.6) then
 635        if(wscp.gt.0d0) then
 636         call escp(evdw2,evdw2_14)
 637        else
 638         evdw2=0
 639         evdw2_14=0
 640        endif
 641       else
 642 !        write (iout,*) "Soft-sphere SCP potential"
 643         call escp_soft_sphere(evdw2,evdw2_14)
 644       endif
 645 !        write(iout,*) "in etotal before ebond",ipot
 646
 647 !
 648 ! Calculate the bond-stretching energy
 649 !
 650       call ebond(estr)
 651 !       print *,"EBOND",estr
 652 !       write(iout,*) "in etotal afer ebond",ipot
 653
 654 !
 655 ! Calculate the disulfide-bridge and other energy and the contributions
 656 ! from other distance constraints.
 657 !      print *,'Calling EHPB'
 658       call edis(ehpb)
 659 !elwrite(iout,*) "in etotal afer edis",ipot
 660 !      print *,'EHPB exitted succesfully.'
 661 !
 662 ! Calculate the virtual-bond-angle energy.
 663 !       write(iout,*) "in etotal afer edis",ipot
 664
 665       if (wang.gt.0.0d0) then
 666         call ebend(ebe,ethetacnstr)
 667       else
 668         ebe=0
 669         ethetacnstr=0
 670       endif
 671 !       write(iout,*) "in etotal afer ebe",ipot
 672
 673 !      print *,"Processor",myrank," computed UB"
 674 !
 675 ! Calculate the SC local energy.
 676 !
 677       call esc(escloc)
 678 !elwrite(iout,*) "in etotal afer esc",ipot
 679 !      print *,"Processor",myrank," computed USC"
 680 !
 681 ! Calculate the virtual-bond torsional energy.
 682 !
 683 !d    print *,'nterm=',nterm
 684       if (wtor.gt.0) then
 685        call etor(etors,edihcnstr)
 686       else
 687        etors=0
 688        edihcnstr=0
 689       endif
 690 !      print *,"Processor",myrank," computed Utor"
 691
 692 !
 693 ! 6/23/01 Calculate double-torsional energy
 694 !
 695 !elwrite(iout,*) "in etotal",ipot
 696       if (wtor_d.gt.0) then
 697        call etor_d(etors_d)
 698       else
 699        etors_d=0
 700       endif
 701 !      print *,"Processor",myrank," computed Utord"
 702 !
 703 ! 21/5/07 Calculate local sicdechain correlation energy
 704 !
 705       if (wsccor.gt.0.0d0) then
 706         call eback_sc_corr(esccor)
 707       else
 708         esccor=0.0d0
 709       endif
 710
 711 !      write(iout,*) "before multibody"
 712       call flush(iout)
 713 !      print *,"Processor",myrank," computed Usccorr"
 714 !
 715 ! 12/1/95 Multi-body terms
 716 !
 717       n_corr=0
 718       n_corr1=0
 719       call flush(iout)
 720       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 721           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 722          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 723 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 724 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 725       else
 726          ecorr=0.0d0
 727          ecorr5=0.0d0
 728          ecorr6=0.0d0
 729          eturn6=0.0d0
 730       endif
 731 !elwrite(iout,*) "in etotal",ipot
 732       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 733          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 734 !d         write (iout,*) "multibody_hb ecorr",ecorr
 735       endif
 736 !      write(iout,*) "afeter  multibody hb"
 737
 738 !      print *,"Processor",myrank," computed Ucorr"
 739 !
 740 ! If performing constraint dynamics, call the constraint energy
 741 !  after the equilibration time
 742       if(usampl.and.totT.gt.eq_time) then
 743 !elwrite(iout,*) "afeter  multibody hb"
 744          call EconstrQ
 745 !elwrite(iout,*) "afeter  multibody hb"
 746          call Econstr_back
 747 !elwrite(iout,*) "afeter  multibody hb"
 748       else
 749          Uconst=0.0d0
 750          Uconst_back=0.0d0
 751       endif
 752       call flush(iout)
 753 !         write(iout,*) "after Econstr"
 754
 755       if (wliptran.gt.0) then
 756 !        print *,"PRZED WYWOLANIEM"
 757         call Eliptransfer(eliptran)
 758       else
 759        eliptran=0.0d0
 760       endif
 761       if (fg_rank.eq.0) then
 762       if (AFMlog.gt.0) then
 763         call AFMforce(Eafmforce)
 764       else if (selfguide.gt.0) then
 765         call AFMvel(Eafmforce)
 766       endif
 767       endif
 768       if (tubemode.eq.1) then
 769        call calctube(etube)
 770       else if (tubemode.eq.2) then
 771        call calctube2(etube)
 772       elseif (tubemode.eq.3) then
 773        call calcnano(etube)
 774       else
 775        etube=0.0d0
 776       endif
 777 !--------------------------------------------------------
 778 !       write (iout,*) "NRES_MOLEC(2),",nres_molec(2)
 779 !      print *,"before",ees,evdw1,ecorr
 780 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 781       if (nres_molec(2).gt.0) then
 782       call ebond_nucl(estr_nucl)
 783       call ebend_nucl(ebe_nucl)
 784       call etor_nucl(etors_nucl)
 785       call esb_gb(evdwsb,eelsb)
 786       call epp_nucl_sub(evdwpp,eespp)
 787       call epsb(evdwpsb,eelpsb)
 788       call esb(esbloc)
 789       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 790       else
 791        etors_nucl=0.0d0
 792        estr_nucl=0.0d0
 793        ecorr3_nucl=0.0d0
 794        ebe_nucl=0.0d0
 795        evdwsb=0.0d0
 796        eelsb=0.0d0
 797        esbloc=0.0d0
 798        evdwpsb=0.0d0
 799        eelpsb=0.0d0
 800        evdwpp=0.0d0
 801        eespp=0.0d0
 802       endif
 803 !      write(iout,*) ecorr_nucl,"ecorr_nucl",nres_molec(2)
 804       if (nfgtasks.gt.1) then
 805       if (fg_rank.eq.0) then
 806       call ecatcat(ecationcation)
 807       endif
 808       else
 809       call ecatcat(ecationcation)
 810       endif
 811       call ecat_prot(ecation_prot)
 812       if (nres_molec(2).gt.0) then
 813       call eprot_sc_base(escbase)
 814       call epep_sc_base(epepbase)
 815       call eprot_sc_phosphate(escpho)
 816       call eprot_pep_phosphate(epeppho)
 817       else
 818       epepbase=0.0
 819       escbase=0.0
 820       escpho=0.0
 821       epeppho=0.0
 822       endif
 823 !      call ecatcat(ecationcation)
 824 !      print *,"after ebend", ebe_nucl
 825 #ifdef TIMING
 826       time_enecalc=time_enecalc+MPI_Wtime()-time00
 827 #endif
 828 !      print *,"Processor",myrank," computed Uconstr"
 829 #ifdef TIMING
 830       time00=MPI_Wtime()
 831 #endif
 832 !
 833 ! Sum the energies
 834 !
 835       energia(1)=evdw
 836 #ifdef SCP14
 837       energia(2)=evdw2-evdw2_14
 838       energia(18)=evdw2_14
 839 #else
 840       energia(2)=evdw2
 841       energia(18)=0.0d0
 842 #endif
 843 #ifdef SPLITELE
 844       energia(3)=ees
 845       energia(16)=evdw1
 846 #else
 847       energia(3)=ees+evdw1
 848       energia(16)=0.0d0
 849 #endif
 850       energia(4)=ecorr
 851       energia(5)=ecorr5
 852       energia(6)=ecorr6
 853       energia(7)=eel_loc
 854       energia(8)=eello_turn3
 855       energia(9)=eello_turn4
 856       energia(10)=eturn6
 857       energia(11)=ebe
 858       energia(12)=escloc
 859       energia(13)=etors
 860       energia(14)=etors_d
 861       energia(15)=ehpb
 862       energia(19)=edihcnstr
 863       energia(17)=estr
 864       energia(20)=Uconst+Uconst_back
 865       energia(21)=esccor
 866       energia(22)=eliptran
 867       energia(23)=Eafmforce
 868       energia(24)=ethetacnstr
 869       energia(25)=etube
 870 !---------------------------------------------------------------
 871       energia(26)=evdwpp
 872       energia(27)=eespp
 873       energia(28)=evdwpsb
 874       energia(29)=eelpsb
 875       energia(30)=evdwsb
 876       energia(31)=eelsb
 877       energia(32)=estr_nucl
 878       energia(33)=ebe_nucl
 879       energia(34)=esbloc
 880       energia(35)=etors_nucl
 881       energia(36)=etors_d_nucl
 882       energia(37)=ecorr_nucl
 883       energia(38)=ecorr3_nucl
 884 !----------------------------------------------------------------------
 885 !    Here are the energies showed per procesor if the are more processors
 886 !    per molecule then we sum it up in sum_energy subroutine
 887 !      print *," Processor",myrank," calls SUM_ENERGY"
 888       energia(41)=ecation_prot
 889       energia(42)=ecationcation
 890       energia(46)=escbase
 891       energia(47)=epepbase
 892       energia(48)=escpho
 893       energia(49)=epeppho
 894       call sum_energy(energia,.true.)
 895       if (dyn_ss) call dyn_set_nss
 896 !      print *," Processor",myrank," left SUM_ENERGY"
 897 #ifdef TIMING
 898       time_sumene=time_sumene+MPI_Wtime()-time00
 899 #endif
 900 !        call enerprint(energia)
 901 !elwrite(iout,*)"finish etotal"
 902       return
 903       end subroutine etotal
 904 !-----------------------------------------------------------------------------
 905       subroutine sum_energy(energia,reduce)
 906 !      implicit real*8 (a-h,o-z)
 907 !      include 'DIMENSIONS'
 908 #ifndef ISNAN
 909       external proc_proc
 910 #ifdef WINPGI
 911 !MS$ATTRIBUTES C ::  proc_proc
 912 #endif
 913 #endif
 914 #ifdef MPI
 915       include "mpif.h"
 916 #endif
 917 !      include 'COMMON.SETUP'
 918 !      include 'COMMON.IOUNITS'
 919       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 920 !      include 'COMMON.FFIELD'
 921 !      include 'COMMON.DERIV'
 922 !      include 'COMMON.INTERACT'
 923 !      include 'COMMON.SBRIDGE'
 924 !      include 'COMMON.CHAIN'
 925 !      include 'COMMON.VAR'
 926 !      include 'COMMON.CONTROL'
 927 !      include 'COMMON.TIME1'
 928       logical :: reduce
 929       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 930       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 931       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 932         eliptran,etube, Eafmforce,ethetacnstr
 933       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 934                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 935                       ecorr3_nucl
 936       real(kind=8) :: ecation_prot,ecationcation
 937       real(kind=8) :: escbase,epepbase,escpho,epeppho
 938       integer :: i
 939 #ifdef MPI
 940       integer :: ierr
 941       real(kind=8) :: time00
 942       if (nfgtasks.gt.1 .and. reduce) then
 943
 944 #ifdef DEBUG
 945         write (iout,*) "energies before REDUCE"
 946         call enerprint(energia)
 947         call flush(iout)
 948 #endif
 949         do i=0,n_ene
 950           enebuff(i)=energia(i)
 951         enddo
 952         time00=MPI_Wtime()
 953         call MPI_Barrier(FG_COMM,IERR)
 954         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 955         time00=MPI_Wtime()
 956         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 957           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 958 #ifdef DEBUG
 959         write (iout,*) "energies after REDUCE"
 960         call enerprint(energia)
 961         call flush(iout)
 962 #endif
 963         time_Reduce=time_Reduce+MPI_Wtime()-time00
 964       endif
 965       if (fg_rank.eq.0) then
 966 #endif
 967       evdw=energia(1)
 968 #ifdef SCP14
 969       evdw2=energia(2)+energia(18)
 970       evdw2_14=energia(18)
 971 #else
 972       evdw2=energia(2)
 973 #endif
 974 #ifdef SPLITELE
 975       ees=energia(3)
 976       evdw1=energia(16)
 977 #else
 978       ees=energia(3)
 979       evdw1=0.0d0
 980 #endif
 981       ecorr=energia(4)
 982       ecorr5=energia(5)
 983       ecorr6=energia(6)
 984       eel_loc=energia(7)
 985       eello_turn3=energia(8)
 986       eello_turn4=energia(9)
 987       eturn6=energia(10)
 988       ebe=energia(11)
 989       escloc=energia(12)
 990       etors=energia(13)
 991       etors_d=energia(14)
 992       ehpb=energia(15)
 993       edihcnstr=energia(19)
 994       estr=energia(17)
 995       Uconst=energia(20)
 996       esccor=energia(21)
 997       eliptran=energia(22)
 998       Eafmforce=energia(23)
 999       ethetacnstr=energia(24)
1000       etube=energia(25)
1001       evdwpp=energia(26)
1002       eespp=energia(27)
1003       evdwpsb=energia(28)
1004       eelpsb=energia(29)
1005       evdwsb=energia(30)
1006       eelsb=energia(31)
1007       estr_nucl=energia(32)
1008       ebe_nucl=energia(33)
1009       esbloc=energia(34)
1010       etors_nucl=energia(35)
1011       etors_d_nucl=energia(36)
1012       ecorr_nucl=energia(37)
1013       ecorr3_nucl=energia(38)
1014       ecation_prot=energia(41)
1015       ecationcation=energia(42)
1016       escbase=energia(46)
1017       epepbase=energia(47)
1018       escpho=energia(48)
1019       epeppho=energia(49)
1020 !      energia(41)=ecation_prot
1021 !      energia(42)=ecationcation
1022
1023
1024 #ifdef SPLITELE
1025       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
1026        +wang*ebe+wtor*etors+wscloc*escloc &
1027        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1028        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1029        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1030        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1031        +Eafmforce+ethetacnstr  &
1032        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1033        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1034        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1035        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1036        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1037        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
1038 #else
1039       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
1040        +wang*ebe+wtor*etors+wscloc*escloc &
1041        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
1042        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
1043        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
1044        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
1045        +Eafmforce+ethetacnstr &
1046        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
1047        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
1048        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
1049        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
1050        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
1051        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
1052 #endif
1053       energia(0)=etot
1054 ! detecting NaNQ
1055 #ifdef ISNAN
1056 #ifdef AIX
1057       if (isnan(etot).ne.0) energia(0)=1.0d+99
1058 #else
1059       if (isnan(etot)) energia(0)=1.0d+99
1060 #endif
1061 #else
1062       i=0
1063 #ifdef WINPGI
1064       idumm=proc_proc(etot,i)
1065 #else
1066       call proc_proc(etot,i)
1067 #endif
1068       if(i.eq.1)energia(0)=1.0d+99
1069 #endif
1070 #ifdef MPI
1071       endif
1072 #endif
1073 !      call enerprint(energia)
1074       call flush(iout)
1075       return
1076       end subroutine sum_energy
1077 !-----------------------------------------------------------------------------
1078       subroutine rescale_weights(t_bath)
1079 !      implicit real*8 (a-h,o-z)
1080 #ifdef MPI
1081       include 'mpif.h'
1082 #endif
1083 !      include 'DIMENSIONS'
1084 !      include 'COMMON.IOUNITS'
1085 !      include 'COMMON.FFIELD'
1086 !      include 'COMMON.SBRIDGE'
1087       real(kind=8) :: kfac=2.4d0
1088       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
1089 !el local variables
1090       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
1091       real(kind=8) :: T0=3.0d2
1092       integer :: ierror
1093 !      facT=temp0/t_bath
1094 !      facT=2*temp0/(t_bath+temp0)
1095       if (rescale_mode.eq.0) then
1096         facT(1)=1.0d0
1097         facT(2)=1.0d0
1098         facT(3)=1.0d0
1099         facT(4)=1.0d0
1100         facT(5)=1.0d0
1101         facT(6)=1.0d0
1102       else if (rescale_mode.eq.1) then
1103         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
1104         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1105         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1106         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1107         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1108 #ifdef WHAM_RUN
1109 !#if defined(WHAM_RUN) || defined(CLUSTER)
1110 #if defined(FUNCTH)
1111 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
1112         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1113 #elif defined(FUNCT)
1114         facT(6)=t_bath/T0
1115 #else
1116         facT(6)=1.0d0
1117 #endif
1118 #endif
1119       else if (rescale_mode.eq.2) then
1120         x=t_bath/temp0
1121         x2=x*x
1122         x3=x2*x
1123         x4=x3*x
1124         x5=x4*x
1125         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
1126         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
1127         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
1128         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
1129         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
1130 #ifdef WHAM_RUN
1131 !#if defined(WHAM_RUN) || defined(CLUSTER)
1132 #if defined(FUNCTH)
1133         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
1134 #elif defined(FUNCT)
1135         facT(6)=t_bath/T0
1136 #else
1137         facT(6)=1.0d0
1138 #endif
1139 #endif
1140       else
1141         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1142         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1143 #ifdef MPI
1144        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1145 #endif
1146        stop 555
1147       endif
1148       welec=weights(3)*fact(1)
1149       wcorr=weights(4)*fact(3)
1150       wcorr5=weights(5)*fact(4)
1151       wcorr6=weights(6)*fact(5)
1152       wel_loc=weights(7)*fact(2)
1153       wturn3=weights(8)*fact(2)
1154       wturn4=weights(9)*fact(3)
1155       wturn6=weights(10)*fact(5)
1156       wtor=weights(13)*fact(1)
1157       wtor_d=weights(14)*fact(2)
1158       wsccor=weights(21)*fact(1)
1159
1160       return
1161       end subroutine rescale_weights
1162 !-----------------------------------------------------------------------------
1163       subroutine enerprint(energia)
1164 !      implicit real*8 (a-h,o-z)
1165 !      include 'DIMENSIONS'
1166 !      include 'COMMON.IOUNITS'
1167 !      include 'COMMON.FFIELD'
1168 !      include 'COMMON.SBRIDGE'
1169 !      include 'COMMON.MD'
1170       real(kind=8) :: energia(0:n_ene)
1171 !el local variables
1172       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
1173       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
1174       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
1175        etube,ethetacnstr,Eafmforce
1176       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1177                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1178                       ecorr3_nucl
1179       real(kind=8) :: ecation_prot,ecationcation
1180       real(kind=8) :: escbase,epepbase,escpho,epeppho
1181
1182       etot=energia(0)
1183       evdw=energia(1)
1184       evdw2=energia(2)
1185 #ifdef SCP14
1186       evdw2=energia(2)+energia(18)
1187 #else
1188       evdw2=energia(2)
1189 #endif
1190       ees=energia(3)
1191 #ifdef SPLITELE
1192       evdw1=energia(16)
1193 #endif
1194       ecorr=energia(4)
1195       ecorr5=energia(5)
1196       ecorr6=energia(6)
1197       eel_loc=energia(7)
1198       eello_turn3=energia(8)
1199       eello_turn4=energia(9)
1200       eello_turn6=energia(10)
1201       ebe=energia(11)
1202       escloc=energia(12)
1203       etors=energia(13)
1204       etors_d=energia(14)
1205       ehpb=energia(15)
1206       edihcnstr=energia(19)
1207       estr=energia(17)
1208       Uconst=energia(20)
1209       esccor=energia(21)
1210       eliptran=energia(22)
1211       Eafmforce=energia(23)
1212       ethetacnstr=energia(24)
1213       etube=energia(25)
1214       evdwpp=energia(26)
1215       eespp=energia(27)
1216       evdwpsb=energia(28)
1217       eelpsb=energia(29)
1218       evdwsb=energia(30)
1219       eelsb=energia(31)
1220       estr_nucl=energia(32)
1221       ebe_nucl=energia(33)
1222       esbloc=energia(34)
1223       etors_nucl=energia(35)
1224       etors_d_nucl=energia(36)
1225       ecorr_nucl=energia(37)
1226       ecorr3_nucl=energia(38)
1227       ecation_prot=energia(41)
1228       ecationcation=energia(42)
1229       escbase=energia(46)
1230       epepbase=energia(47)
1231       escpho=energia(48)
1232       epeppho=energia(49)
1233 #ifdef SPLITELE
1234       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1235         estr,wbond,ebe,wang,&
1236         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1237         ecorr,wcorr,&
1238         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1239         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1240         edihcnstr,ethetacnstr,ebr*nss,&
1241         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1242         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1243         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1244         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1245         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1246         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1247         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1248         etot
1249    10 format (/'Virtual-chain energies:'// &
1250        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1251        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1252        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1253        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1254        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1255        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1256        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1257        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1258        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1259        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1260        ' (SS bridges & dist. cnstr.)'/ &
1261        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1262        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1263        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1264        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1265        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1266        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1267        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1268        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1269        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1270        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1271        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1272        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1273        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1274        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1275        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1276        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1277        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1278        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1279        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1280        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1281        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1282        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1283        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1284        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1285        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1286        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1287        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1288        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1289        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1290        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1291        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1292        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1293        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1294        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1295        'ETOT=  ',1pE16.6,' (total)')
1296 #else
1297       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1298         estr,wbond,ebe,wang,&
1299         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1300         ecorr,wcorr,&
1301         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1302         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1303         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,     &
1304         etube,wtube, &
1305         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1306         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb&
1307         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl&
1308         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1309         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1310         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1311         etot
1312    10 format (/'Virtual-chain energies:'// &
1313        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1314        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1315        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1316        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1317        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1318        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1319        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1320        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1321        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1322        ' (SS bridges & dist. cnstr.)'/ &
1323        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1324        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1325        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1326        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1327        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1328        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1329        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1330        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1331        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1332        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1333        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1334        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1335        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1336        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1337        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1338        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1339        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1340        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1341        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1342        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1343        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1344        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1345        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1346        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1347        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1348        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1349        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1350        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1351        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1352        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1353        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1354        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1355        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1356        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1357        'ETOT=  ',1pE16.6,' (total)')
1358 #endif
1359       return
1360       end subroutine enerprint
1361 !-----------------------------------------------------------------------------
1362       subroutine elj(evdw)
1363 !
1364 ! This subroutine calculates the interaction energy of nonbonded side chains
1365 ! assuming the LJ potential of interaction.
1366 !
1367 !      implicit real*8 (a-h,o-z)
1368 !      include 'DIMENSIONS'
1369       real(kind=8),parameter :: accur=1.0d-10
1370 !      include 'COMMON.GEO'
1371 !      include 'COMMON.VAR'
1372 !      include 'COMMON.LOCAL'
1373 !      include 'COMMON.CHAIN'
1374 !      include 'COMMON.DERIV'
1375 !      include 'COMMON.INTERACT'
1376 !      include 'COMMON.TORSION'
1377 !      include 'COMMON.SBRIDGE'
1378 !      include 'COMMON.NAMES'
1379 !      include 'COMMON.IOUNITS'
1380 !      include 'COMMON.CONTACTS'
1381       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1382       integer :: num_conti
1383 !el local variables
1384       integer :: i,itypi,iint,j,itypi1,itypj,k
1385       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
1386       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1387       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1388
1389 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1390       evdw=0.0D0
1391 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1392 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1393 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1394 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1395
1396       do i=iatsc_s,iatsc_e
1397         itypi=iabs(itype(i,1))
1398         if (itypi.eq.ntyp1) cycle
1399         itypi1=iabs(itype(i+1,1))
1400         xi=c(1,nres+i)
1401         yi=c(2,nres+i)
1402         zi=c(3,nres+i)
1403 ! Change 12/1/95
1404         num_conti=0
1405 !
1406 ! Calculate SC interaction energy.
1407 !
1408         do iint=1,nint_gr(i)
1409 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1410 !d   &                  'iend=',iend(i,iint)
1411           do j=istart(i,iint),iend(i,iint)
1412             itypj=iabs(itype(j,1))
1413             if (itypj.eq.ntyp1) cycle
1414             xj=c(1,nres+j)-xi
1415             yj=c(2,nres+j)-yi
1416             zj=c(3,nres+j)-zi
1417 ! Change 12/1/95 to calculate four-body interactions
1418             rij=xj*xj+yj*yj+zj*zj
1419             rrij=1.0D0/rij
1420 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1421             eps0ij=eps(itypi,itypj)
1422             fac=rrij**expon2
1423             e1=fac*fac*aa_aq(itypi,itypj)
1424             e2=fac*bb_aq(itypi,itypj)
1425             evdwij=e1+e2
1426 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1427 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1428 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1429 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1430 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1431 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1432             evdw=evdw+evdwij
1433 !
1434 ! Calculate the components of the gradient in DC and X
1435 !
1436             fac=-rrij*(e1+evdwij)
1437             gg(1)=xj*fac
1438             gg(2)=yj*fac
1439             gg(3)=zj*fac
1440             do k=1,3
1441               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1442               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1443               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1444               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1445             enddo
1446 !grad            do k=i,j-1
1447 !grad              do l=1,3
1448 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1449 !grad              enddo
1450 !grad            enddo
1451 !
1452 ! 12/1/95, revised on 5/20/97
1453 !
1454 ! Calculate the contact function. The ith column of the array JCONT will
1455 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1456 ! greater than I). The arrays FACONT and GACONT will contain the values of
1457 ! the contact function and its derivative.
1458 !
1459 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1460 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1461 ! Uncomment next line, if the correlation interactions are contact function only
1462             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1463               rij=dsqrt(rij)
1464               sigij=sigma(itypi,itypj)
1465               r0ij=rs0(itypi,itypj)
1466 !
1467 ! Check whether the SC's are not too far to make a contact.
1468 !
1469               rcut=1.5d0*r0ij
1470               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1471 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1472 !
1473               if (fcont.gt.0.0D0) then
1474 ! If the SC-SC distance if close to sigma, apply spline.
1475 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1476 !Adam &             fcont1,fprimcont1)
1477 !Adam           fcont1=1.0d0-fcont1
1478 !Adam           if (fcont1.gt.0.0d0) then
1479 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1480 !Adam             fcont=fcont*fcont1
1481 !Adam           endif
1482 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1483 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1484 !ga             do k=1,3
1485 !ga               gg(k)=gg(k)*eps0ij
1486 !ga             enddo
1487 !ga             eps0ij=-evdwij*eps0ij
1488 ! Uncomment for AL's type of SC correlation interactions.
1489 !adam           eps0ij=-evdwij
1490                 num_conti=num_conti+1
1491                 jcont(num_conti,i)=j
1492                 facont(num_conti,i)=fcont*eps0ij
1493                 fprimcont=eps0ij*fprimcont/rij
1494                 fcont=expon*fcont
1495 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1496 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1497 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1498 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1499                 gacont(1,num_conti,i)=-fprimcont*xj
1500                 gacont(2,num_conti,i)=-fprimcont*yj
1501                 gacont(3,num_conti,i)=-fprimcont*zj
1502 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1503 !d              write (iout,'(2i3,3f10.5)')
1504 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1505               endif
1506             endif
1507           enddo      ! j
1508         enddo        ! iint
1509 ! Change 12/1/95
1510         num_cont(i)=num_conti
1511       enddo          ! i
1512       do i=1,nct
1513         do j=1,3
1514           gvdwc(j,i)=expon*gvdwc(j,i)
1515           gvdwx(j,i)=expon*gvdwx(j,i)
1516         enddo
1517       enddo
1518 !******************************************************************************
1519 !
1520 !                              N O T E !!!
1521 !
1522 ! To save time, the factor of EXPON has been extracted from ALL components
1523 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1524 ! use!
1525 !
1526 !******************************************************************************
1527       return
1528       end subroutine elj
1529 !-----------------------------------------------------------------------------
1530       subroutine eljk(evdw)
1531 !
1532 ! This subroutine calculates the interaction energy of nonbonded side chains
1533 ! assuming the LJK potential of interaction.
1534 !
1535 !      implicit real*8 (a-h,o-z)
1536 !      include 'DIMENSIONS'
1537 !      include 'COMMON.GEO'
1538 !      include 'COMMON.VAR'
1539 !      include 'COMMON.LOCAL'
1540 !      include 'COMMON.CHAIN'
1541 !      include 'COMMON.DERIV'
1542 !      include 'COMMON.INTERACT'
1543 !      include 'COMMON.IOUNITS'
1544 !      include 'COMMON.NAMES'
1545       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1546       logical :: scheck
1547 !el local variables
1548       integer :: i,iint,j,itypi,itypi1,k,itypj
1549       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1550       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1551
1552 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1553       evdw=0.0D0
1554       do i=iatsc_s,iatsc_e
1555         itypi=iabs(itype(i,1))
1556         if (itypi.eq.ntyp1) cycle
1557         itypi1=iabs(itype(i+1,1))
1558         xi=c(1,nres+i)
1559         yi=c(2,nres+i)
1560         zi=c(3,nres+i)
1561 !
1562 ! Calculate SC interaction energy.
1563 !
1564         do iint=1,nint_gr(i)
1565           do j=istart(i,iint),iend(i,iint)
1566             itypj=iabs(itype(j,1))
1567             if (itypj.eq.ntyp1) cycle
1568             xj=c(1,nres+j)-xi
1569             yj=c(2,nres+j)-yi
1570             zj=c(3,nres+j)-zi
1571             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1572             fac_augm=rrij**expon
1573             e_augm=augm(itypi,itypj)*fac_augm
1574             r_inv_ij=dsqrt(rrij)
1575             rij=1.0D0/r_inv_ij
1576             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1577             fac=r_shift_inv**expon
1578             e1=fac*fac*aa_aq(itypi,itypj)
1579             e2=fac*bb_aq(itypi,itypj)
1580             evdwij=e_augm+e1+e2
1581 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1582 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1583 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1584 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1585 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1586 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1587 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1588             evdw=evdw+evdwij
1589 !
1590 ! Calculate the components of the gradient in DC and X
1591 !
1592             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1593             gg(1)=xj*fac
1594             gg(2)=yj*fac
1595             gg(3)=zj*fac
1596             do k=1,3
1597               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1598               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1599               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1600               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1601             enddo
1602 !grad            do k=i,j-1
1603 !grad              do l=1,3
1604 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1605 !grad              enddo
1606 !grad            enddo
1607           enddo      ! j
1608         enddo        ! iint
1609       enddo          ! i
1610       do i=1,nct
1611         do j=1,3
1612           gvdwc(j,i)=expon*gvdwc(j,i)
1613           gvdwx(j,i)=expon*gvdwx(j,i)
1614         enddo
1615       enddo
1616       return
1617       end subroutine eljk
1618 !-----------------------------------------------------------------------------
1619       subroutine ebp(evdw)
1620 !
1621 ! This subroutine calculates the interaction energy of nonbonded side chains
1622 ! assuming the Berne-Pechukas potential of interaction.
1623 !
1624       use comm_srutu
1625       use calc_data
1626 !      implicit real*8 (a-h,o-z)
1627 !      include 'DIMENSIONS'
1628 !      include 'COMMON.GEO'
1629 !      include 'COMMON.VAR'
1630 !      include 'COMMON.LOCAL'
1631 !      include 'COMMON.CHAIN'
1632 !      include 'COMMON.DERIV'
1633 !      include 'COMMON.NAMES'
1634 !      include 'COMMON.INTERACT'
1635 !      include 'COMMON.IOUNITS'
1636 !      include 'COMMON.CALC'
1637       use comm_srutu
1638 !el      integer :: icall
1639 !el      common /srutu/ icall
1640 !     double precision rrsave(maxdim)
1641       logical :: lprn
1642 !el local variables
1643       integer :: iint,itypi,itypi1,itypj
1644       real(kind=8) :: rrij,xi,yi,zi
1645       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1646
1647 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1648       evdw=0.0D0
1649 !     if (icall.eq.0) then
1650 !       lprn=.true.
1651 !     else
1652         lprn=.false.
1653 !     endif
1654 !el      ind=0
1655       do i=iatsc_s,iatsc_e
1656         itypi=iabs(itype(i,1))
1657         if (itypi.eq.ntyp1) cycle
1658         itypi1=iabs(itype(i+1,1))
1659         xi=c(1,nres+i)
1660         yi=c(2,nres+i)
1661         zi=c(3,nres+i)
1662         dxi=dc_norm(1,nres+i)
1663         dyi=dc_norm(2,nres+i)
1664         dzi=dc_norm(3,nres+i)
1665 !        dsci_inv=dsc_inv(itypi)
1666         dsci_inv=vbld_inv(i+nres)
1667 !
1668 ! Calculate SC interaction energy.
1669 !
1670         do iint=1,nint_gr(i)
1671           do j=istart(i,iint),iend(i,iint)
1672 !el            ind=ind+1
1673             itypj=iabs(itype(j,1))
1674             if (itypj.eq.ntyp1) cycle
1675 !            dscj_inv=dsc_inv(itypj)
1676             dscj_inv=vbld_inv(j+nres)
1677             chi1=chi(itypi,itypj)
1678             chi2=chi(itypj,itypi)
1679             chi12=chi1*chi2
1680             chip1=chip(itypi)
1681             chip2=chip(itypj)
1682             chip12=chip1*chip2
1683             alf1=alp(itypi)
1684             alf2=alp(itypj)
1685             alf12=0.5D0*(alf1+alf2)
1686 ! For diagnostics only!!!
1687 !           chi1=0.0D0
1688 !           chi2=0.0D0
1689 !           chi12=0.0D0
1690 !           chip1=0.0D0
1691 !           chip2=0.0D0
1692 !           chip12=0.0D0
1693 !           alf1=0.0D0
1694 !           alf2=0.0D0
1695 !           alf12=0.0D0
1696             xj=c(1,nres+j)-xi
1697             yj=c(2,nres+j)-yi
1698             zj=c(3,nres+j)-zi
1699             dxj=dc_norm(1,nres+j)
1700             dyj=dc_norm(2,nres+j)
1701             dzj=dc_norm(3,nres+j)
1702             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1703 !d          if (icall.eq.0) then
1704 !d            rrsave(ind)=rrij
1705 !d          else
1706 !d            rrij=rrsave(ind)
1707 !d          endif
1708             rij=dsqrt(rrij)
1709 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1710             call sc_angular
1711 ! Calculate whole angle-dependent part of epsilon and contributions
1712 ! to its derivatives
1713             fac=(rrij*sigsq)**expon2
1714             e1=fac*fac*aa_aq(itypi,itypj)
1715             e2=fac*bb_aq(itypi,itypj)
1716             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1717             eps2der=evdwij*eps3rt
1718             eps3der=evdwij*eps2rt
1719             evdwij=evdwij*eps2rt*eps3rt
1720             evdw=evdw+evdwij
1721             if (lprn) then
1722             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1723             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1724 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1725 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1726 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1727 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1728 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1729 !d     &        evdwij
1730             endif
1731 ! Calculate gradient components.
1732             e1=e1*eps1*eps2rt**2*eps3rt**2
1733             fac=-expon*(e1+evdwij)
1734             sigder=fac/sigsq
1735             fac=rrij*fac
1736 ! Calculate radial part of the gradient
1737             gg(1)=xj*fac
1738             gg(2)=yj*fac
1739             gg(3)=zj*fac
1740 ! Calculate the angular part of the gradient and sum add the contributions
1741 ! to the appropriate components of the Cartesian gradient.
1742             call sc_grad
1743           enddo      ! j
1744         enddo        ! iint
1745       enddo          ! i
1746 !     stop
1747       return
1748       end subroutine ebp
1749 !-----------------------------------------------------------------------------
1750       subroutine egb(evdw)
1751 !
1752 ! This subroutine calculates the interaction energy of nonbonded side chains
1753 ! assuming the Gay-Berne potential of interaction.
1754 !
1755       use calc_data
1756 !      implicit real*8 (a-h,o-z)
1757 !      include 'DIMENSIONS'
1758 !      include 'COMMON.GEO'
1759 !      include 'COMMON.VAR'
1760 !      include 'COMMON.LOCAL'
1761 !      include 'COMMON.CHAIN'
1762 !      include 'COMMON.DERIV'
1763 !      include 'COMMON.NAMES'
1764 !      include 'COMMON.INTERACT'
1765 !      include 'COMMON.IOUNITS'
1766 !      include 'COMMON.CALC'
1767 !      include 'COMMON.CONTROL'
1768 !      include 'COMMON.SBRIDGE'
1769       logical :: lprn
1770 !el local variables
1771       integer :: iint,itypi,itypi1,itypj,subchap
1772       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1773       real(kind=8) :: evdw,sig0ij
1774       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1775                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1776                     sslipi,sslipj,faclip
1777       integer :: ii
1778       real(kind=8) :: fracinbuf
1779
1780 !cccc      energy_dec=.false.
1781 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1782       evdw=0.0D0
1783       lprn=.false.
1784 !     if (icall.eq.0) lprn=.false.
1785 !el      ind=0
1786       dCAVdOM2=0.0d0
1787       dGCLdOM2=0.0d0
1788       dPOLdOM2=0.0d0
1789       dCAVdOM1=0.0d0
1790       dGCLdOM1=0.0d0
1791       dPOLdOM1=0.0d0
1792
1793
1794       do i=iatsc_s,iatsc_e
1795 !C        print *,"I am in EVDW",i
1796         itypi=iabs(itype(i,1))
1797 !        if (i.ne.47) cycle
1798         if (itypi.eq.ntyp1) cycle
1799         itypi1=iabs(itype(i+1,1))
1800         xi=c(1,nres+i)
1801         yi=c(2,nres+i)
1802         zi=c(3,nres+i)
1803           xi=dmod(xi,boxxsize)
1804           if (xi.lt.0) xi=xi+boxxsize
1805           yi=dmod(yi,boxysize)
1806           if (yi.lt.0) yi=yi+boxysize
1807           zi=dmod(zi,boxzsize)
1808           if (zi.lt.0) zi=zi+boxzsize
1809
1810        if ((zi.gt.bordlipbot)  &
1811         .and.(zi.lt.bordliptop)) then
1812 !C the energy transfer exist
1813         if (zi.lt.buflipbot) then
1814 !C what fraction I am in
1815          fracinbuf=1.0d0-  &
1816               ((zi-bordlipbot)/lipbufthick)
1817 !C lipbufthick is thickenes of lipid buffore
1818          sslipi=sscalelip(fracinbuf)
1819          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1820         elseif (zi.gt.bufliptop) then
1821          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1822          sslipi=sscalelip(fracinbuf)
1823          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1824         else
1825          sslipi=1.0d0
1826          ssgradlipi=0.0
1827         endif
1828        else
1829          sslipi=0.0d0
1830          ssgradlipi=0.0
1831        endif
1832 !       print *, sslipi,ssgradlipi
1833         dxi=dc_norm(1,nres+i)
1834         dyi=dc_norm(2,nres+i)
1835         dzi=dc_norm(3,nres+i)
1836 !        dsci_inv=dsc_inv(itypi)
1837         dsci_inv=vbld_inv(i+nres)
1838 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1839 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1840 !
1841 ! Calculate SC interaction energy.
1842 !
1843         do iint=1,nint_gr(i)
1844           do j=istart(i,iint),iend(i,iint)
1845             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1846               call dyn_ssbond_ene(i,j,evdwij)
1847               evdw=evdw+evdwij
1848               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1849                               'evdw',i,j,evdwij,' ss'
1850 !              if (energy_dec) write (iout,*) &
1851 !                              'evdw',i,j,evdwij,' ss'
1852              do k=j+1,iend(i,iint)
1853 !C search over all next residues
1854               if (dyn_ss_mask(k)) then
1855 !C check if they are cysteins
1856 !C              write(iout,*) 'k=',k
1857
1858 !c              write(iout,*) "PRZED TRI", evdwij
1859 !               evdwij_przed_tri=evdwij
1860               call triple_ssbond_ene(i,j,k,evdwij)
1861 !c               if(evdwij_przed_tri.ne.evdwij) then
1862 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1863 !c               endif
1864
1865 !c              write(iout,*) "PO TRI", evdwij
1866 !C call the energy function that removes the artifical triple disulfide
1867 !C bond the soubroutine is located in ssMD.F
1868               evdw=evdw+evdwij
1869               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1870                             'evdw',i,j,evdwij,'tss'
1871               endif!dyn_ss_mask(k)
1872              enddo! k
1873             ELSE
1874 !el            ind=ind+1
1875             itypj=iabs(itype(j,1))
1876             if (itypj.eq.ntyp1) cycle
1877 !             if (j.ne.78) cycle
1878 !            dscj_inv=dsc_inv(itypj)
1879             dscj_inv=vbld_inv(j+nres)
1880 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1881 !              1.0d0/vbld(j+nres) !d
1882 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1883             sig0ij=sigma(itypi,itypj)
1884             chi1=chi(itypi,itypj)
1885             chi2=chi(itypj,itypi)
1886             chi12=chi1*chi2
1887             chip1=chip(itypi)
1888             chip2=chip(itypj)
1889             chip12=chip1*chip2
1890             alf1=alp(itypi)
1891             alf2=alp(itypj)
1892             alf12=0.5D0*(alf1+alf2)
1893 ! For diagnostics only!!!
1894 !           chi1=0.0D0
1895 !           chi2=0.0D0
1896 !           chi12=0.0D0
1897 !           chip1=0.0D0
1898 !           chip2=0.0D0
1899 !           chip12=0.0D0
1900 !           alf1=0.0D0
1901 !           alf2=0.0D0
1902 !           alf12=0.0D0
1903            xj=c(1,nres+j)
1904            yj=c(2,nres+j)
1905            zj=c(3,nres+j)
1906           xj=dmod(xj,boxxsize)
1907           if (xj.lt.0) xj=xj+boxxsize
1908           yj=dmod(yj,boxysize)
1909           if (yj.lt.0) yj=yj+boxysize
1910           zj=dmod(zj,boxzsize)
1911           if (zj.lt.0) zj=zj+boxzsize
1912 !          print *,"tu",xi,yi,zi,xj,yj,zj
1913 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1914 ! this fragment set correct epsilon for lipid phase
1915        if ((zj.gt.bordlipbot)  &
1916        .and.(zj.lt.bordliptop)) then
1917 !C the energy transfer exist
1918         if (zj.lt.buflipbot) then
1919 !C what fraction I am in
1920          fracinbuf=1.0d0-     &
1921              ((zj-bordlipbot)/lipbufthick)
1922 !C lipbufthick is thickenes of lipid buffore
1923          sslipj=sscalelip(fracinbuf)
1924          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1925         elseif (zj.gt.bufliptop) then
1926          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1927          sslipj=sscalelip(fracinbuf)
1928          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1929         else
1930          sslipj=1.0d0
1931          ssgradlipj=0.0
1932         endif
1933        else
1934          sslipj=0.0d0
1935          ssgradlipj=0.0
1936        endif
1937       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1938        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1939       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1940        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1941 !------------------------------------------------
1942       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1943       xj_safe=xj
1944       yj_safe=yj
1945       zj_safe=zj
1946       subchap=0
1947       do xshift=-1,1
1948       do yshift=-1,1
1949       do zshift=-1,1
1950           xj=xj_safe+xshift*boxxsize
1951           yj=yj_safe+yshift*boxysize
1952           zj=zj_safe+zshift*boxzsize
1953           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1954           if(dist_temp.lt.dist_init) then
1955             dist_init=dist_temp
1956             xj_temp=xj
1957             yj_temp=yj
1958             zj_temp=zj
1959             subchap=1
1960           endif
1961        enddo
1962        enddo
1963        enddo
1964        if (subchap.eq.1) then
1965           xj=xj_temp-xi
1966           yj=yj_temp-yi
1967           zj=zj_temp-zi
1968        else
1969           xj=xj_safe-xi
1970           yj=yj_safe-yi
1971           zj=zj_safe-zi
1972        endif
1973             dxj=dc_norm(1,nres+j)
1974             dyj=dc_norm(2,nres+j)
1975             dzj=dc_norm(3,nres+j)
1976 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1977 !            write (iout,*) "j",j," dc_norm",& !d
1978 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1979 !          write(iout,*)"rrij ",rrij
1980 !          write(iout,*)"xj yj zj ", xj, yj, zj
1981 !          write(iout,*)"xi yi zi ", xi, yi, zi
1982 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1983             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1984             rij=dsqrt(rrij)
1985             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1986             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1987 !            print *,sss_ele_cut,sss_ele_grad,&
1988 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1989             if (sss_ele_cut.le.0.0) cycle
1990 ! Calculate angle-dependent terms of energy and contributions to their
1991 ! derivatives.
1992             call sc_angular
1993             sigsq=1.0D0/sigsq
1994             sig=sig0ij*dsqrt(sigsq)
1995             rij_shift=1.0D0/rij-sig+sig0ij
1996 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1997 !            "sig0ij",sig0ij
1998 ! for diagnostics; uncomment
1999 !            rij_shift=1.2*sig0ij
2000 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2001             if (rij_shift.le.0.0D0) then
2002               evdw=1.0D20
2003 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2004 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
2005 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
2006               return
2007             endif
2008             sigder=-sig*sigsq
2009 !---------------------------------------------------------------
2010             rij_shift=1.0D0/rij_shift
2011             fac=rij_shift**expon
2012             faclip=fac
2013             e1=fac*fac*aa!(itypi,itypj)
2014             e2=fac*bb!(itypi,itypj)
2015             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2016             eps2der=evdwij*eps3rt
2017             eps3der=evdwij*eps2rt
2018 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
2019 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
2020 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
2021             evdwij=evdwij*eps2rt*eps3rt
2022             evdw=evdw+evdwij*sss_ele_cut
2023             if (lprn) then
2024             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2025             epsi=bb**2/aa!(itypi,itypj)
2026             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2027               restyp(itypi,1),i,restyp(itypj,1),j, &
2028               epsi,sigm,chi1,chi2,chip1,chip2, &
2029               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
2030               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
2031               evdwij
2032             endif
2033
2034             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
2035                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
2036 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
2037 !            if (energy_dec) write (iout,*) &
2038 !                             'evdw',i,j,evdwij
2039 !                       print *,"ZALAMKA", evdw
2040
2041 ! Calculate gradient components.
2042             e1=e1*eps1*eps2rt**2*eps3rt**2
2043             fac=-expon*(e1+evdwij)*rij_shift
2044             sigder=fac*sigder
2045             fac=rij*fac
2046 !            print *,'before fac',fac,rij,evdwij
2047             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
2048             /sigma(itypi,itypj)*rij
2049 !            print *,'grad part scale',fac,   &
2050 !             evdwij*sss_ele_grad/sss_ele_cut &
2051 !            /sigma(itypi,itypj)*rij
2052 !            fac=0.0d0
2053 ! Calculate the radial part of the gradient
2054             gg(1)=xj*fac
2055             gg(2)=yj*fac
2056             gg(3)=zj*fac
2057 !C Calculate the radial part of the gradient
2058             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
2059        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
2060         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
2061        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
2062             gg_lipj(3)=ssgradlipj*gg_lipi(3)
2063             gg_lipi(3)=gg_lipi(3)*ssgradlipi
2064
2065 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
2066 ! Calculate angular part of the gradient.
2067             call sc_grad
2068             ENDIF    ! dyn_ss
2069           enddo      ! j
2070         enddo        ! iint
2071       enddo          ! i
2072 !       print *,"ZALAMKA", evdw
2073 !      write (iout,*) "Number of loop steps in EGB:",ind
2074 !ccc      energy_dec=.false.
2075       return
2076       end subroutine egb
2077 !-----------------------------------------------------------------------------
2078       subroutine egbv(evdw)
2079 !
2080 ! This subroutine calculates the interaction energy of nonbonded side chains
2081 ! assuming the Gay-Berne-Vorobjev potential of interaction.
2082 !
2083       use comm_srutu
2084       use calc_data
2085 !      implicit real*8 (a-h,o-z)
2086 !      include 'DIMENSIONS'
2087 !      include 'COMMON.GEO'
2088 !      include 'COMMON.VAR'
2089 !      include 'COMMON.LOCAL'
2090 !      include 'COMMON.CHAIN'
2091 !      include 'COMMON.DERIV'
2092 !      include 'COMMON.NAMES'
2093 !      include 'COMMON.INTERACT'
2094 !      include 'COMMON.IOUNITS'
2095 !      include 'COMMON.CALC'
2096       use comm_srutu
2097 !el      integer :: icall
2098 !el      common /srutu/ icall
2099       logical :: lprn
2100 !el local variables
2101       integer :: iint,itypi,itypi1,itypj
2102       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
2103       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
2104
2105 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2106       evdw=0.0D0
2107       lprn=.false.
2108 !     if (icall.eq.0) lprn=.true.
2109 !el      ind=0
2110       do i=iatsc_s,iatsc_e
2111         itypi=iabs(itype(i,1))
2112         if (itypi.eq.ntyp1) cycle
2113         itypi1=iabs(itype(i+1,1))
2114         xi=c(1,nres+i)
2115         yi=c(2,nres+i)
2116         zi=c(3,nres+i)
2117         dxi=dc_norm(1,nres+i)
2118         dyi=dc_norm(2,nres+i)
2119         dzi=dc_norm(3,nres+i)
2120 !        dsci_inv=dsc_inv(itypi)
2121         dsci_inv=vbld_inv(i+nres)
2122 !
2123 ! Calculate SC interaction energy.
2124 !
2125         do iint=1,nint_gr(i)
2126           do j=istart(i,iint),iend(i,iint)
2127 !el            ind=ind+1
2128             itypj=iabs(itype(j,1))
2129             if (itypj.eq.ntyp1) cycle
2130 !            dscj_inv=dsc_inv(itypj)
2131             dscj_inv=vbld_inv(j+nres)
2132             sig0ij=sigma(itypi,itypj)
2133             r0ij=r0(itypi,itypj)
2134             chi1=chi(itypi,itypj)
2135             chi2=chi(itypj,itypi)
2136             chi12=chi1*chi2
2137             chip1=chip(itypi)
2138             chip2=chip(itypj)
2139             chip12=chip1*chip2
2140             alf1=alp(itypi)
2141             alf2=alp(itypj)
2142             alf12=0.5D0*(alf1+alf2)
2143 ! For diagnostics only!!!
2144 !           chi1=0.0D0
2145 !           chi2=0.0D0
2146 !           chi12=0.0D0
2147 !           chip1=0.0D0
2148 !           chip2=0.0D0
2149 !           chip12=0.0D0
2150 !           alf1=0.0D0
2151 !           alf2=0.0D0
2152 !           alf12=0.0D0
2153             xj=c(1,nres+j)-xi
2154             yj=c(2,nres+j)-yi
2155             zj=c(3,nres+j)-zi
2156             dxj=dc_norm(1,nres+j)
2157             dyj=dc_norm(2,nres+j)
2158             dzj=dc_norm(3,nres+j)
2159             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2160             rij=dsqrt(rrij)
2161 ! Calculate angle-dependent terms of energy and contributions to their
2162 ! derivatives.
2163             call sc_angular
2164             sigsq=1.0D0/sigsq
2165             sig=sig0ij*dsqrt(sigsq)
2166             rij_shift=1.0D0/rij-sig+r0ij
2167 ! I hate to put IF's in the loops, but here don't have another choice!!!!
2168             if (rij_shift.le.0.0D0) then
2169               evdw=1.0D20
2170               return
2171             endif
2172             sigder=-sig*sigsq
2173 !---------------------------------------------------------------
2174             rij_shift=1.0D0/rij_shift
2175             fac=rij_shift**expon
2176             e1=fac*fac*aa_aq(itypi,itypj)
2177             e2=fac*bb_aq(itypi,itypj)
2178             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2179             eps2der=evdwij*eps3rt
2180             eps3der=evdwij*eps2rt
2181             fac_augm=rrij**expon
2182             e_augm=augm(itypi,itypj)*fac_augm
2183             evdwij=evdwij*eps2rt*eps3rt
2184             evdw=evdw+evdwij+e_augm
2185             if (lprn) then
2186             sigm=dabs(aa_aq(itypi,itypj)/&
2187             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2188             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2189             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2190               restyp(itypi,1),i,restyp(itypj,1),j,&
2191               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2192               chi1,chi2,chip1,chip2,&
2193               eps1,eps2rt**2,eps3rt**2,&
2194               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2195               evdwij+e_augm
2196             endif
2197 ! Calculate gradient components.
2198             e1=e1*eps1*eps2rt**2*eps3rt**2
2199             fac=-expon*(e1+evdwij)*rij_shift
2200             sigder=fac*sigder
2201             fac=rij*fac-2*expon*rrij*e_augm
2202 ! Calculate the radial part of the gradient
2203             gg(1)=xj*fac
2204             gg(2)=yj*fac
2205             gg(3)=zj*fac
2206 ! Calculate angular part of the gradient.
2207             call sc_grad
2208           enddo      ! j
2209         enddo        ! iint
2210       enddo          ! i
2211       end subroutine egbv
2212 !-----------------------------------------------------------------------------
2213 !el      subroutine sc_angular in module geometry
2214 !-----------------------------------------------------------------------------
2215       subroutine e_softsphere(evdw)
2216 !
2217 ! This subroutine calculates the interaction energy of nonbonded side chains
2218 ! assuming the LJ potential of interaction.
2219 !
2220 !      implicit real*8 (a-h,o-z)
2221 !      include 'DIMENSIONS'
2222       real(kind=8),parameter :: accur=1.0d-10
2223 !      include 'COMMON.GEO'
2224 !      include 'COMMON.VAR'
2225 !      include 'COMMON.LOCAL'
2226 !      include 'COMMON.CHAIN'
2227 !      include 'COMMON.DERIV'
2228 !      include 'COMMON.INTERACT'
2229 !      include 'COMMON.TORSION'
2230 !      include 'COMMON.SBRIDGE'
2231 !      include 'COMMON.NAMES'
2232 !      include 'COMMON.IOUNITS'
2233 !      include 'COMMON.CONTACTS'
2234       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2235 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2236 !el local variables
2237       integer :: i,iint,j,itypi,itypi1,itypj,k
2238       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2239       real(kind=8) :: fac
2240
2241       evdw=0.0D0
2242       do i=iatsc_s,iatsc_e
2243         itypi=iabs(itype(i,1))
2244         if (itypi.eq.ntyp1) cycle
2245         itypi1=iabs(itype(i+1,1))
2246         xi=c(1,nres+i)
2247         yi=c(2,nres+i)
2248         zi=c(3,nres+i)
2249 !
2250 ! Calculate SC interaction energy.
2251 !
2252         do iint=1,nint_gr(i)
2253 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2254 !d   &                  'iend=',iend(i,iint)
2255           do j=istart(i,iint),iend(i,iint)
2256             itypj=iabs(itype(j,1))
2257             if (itypj.eq.ntyp1) cycle
2258             xj=c(1,nres+j)-xi
2259             yj=c(2,nres+j)-yi
2260             zj=c(3,nres+j)-zi
2261             rij=xj*xj+yj*yj+zj*zj
2262 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2263             r0ij=r0(itypi,itypj)
2264             r0ijsq=r0ij*r0ij
2265 !            print *,i,j,r0ij,dsqrt(rij)
2266             if (rij.lt.r0ijsq) then
2267               evdwij=0.25d0*(rij-r0ijsq)**2
2268               fac=rij-r0ijsq
2269             else
2270               evdwij=0.0d0
2271               fac=0.0d0
2272             endif
2273             evdw=evdw+evdwij
2274 !
2275 ! Calculate the components of the gradient in DC and X
2276 !
2277             gg(1)=xj*fac
2278             gg(2)=yj*fac
2279             gg(3)=zj*fac
2280             do k=1,3
2281               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2282               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2283               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2284               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2285             enddo
2286 !grad            do k=i,j-1
2287 !grad              do l=1,3
2288 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2289 !grad              enddo
2290 !grad            enddo
2291           enddo ! j
2292         enddo ! iint
2293       enddo ! i
2294       return
2295       end subroutine e_softsphere
2296 !-----------------------------------------------------------------------------
2297       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2298 !
2299 ! Soft-sphere potential of p-p interaction
2300 !
2301 !      implicit real*8 (a-h,o-z)
2302 !      include 'DIMENSIONS'
2303 !      include 'COMMON.CONTROL'
2304 !      include 'COMMON.IOUNITS'
2305 !      include 'COMMON.GEO'
2306 !      include 'COMMON.VAR'
2307 !      include 'COMMON.LOCAL'
2308 !      include 'COMMON.CHAIN'
2309 !      include 'COMMON.DERIV'
2310 !      include 'COMMON.INTERACT'
2311 !      include 'COMMON.CONTACTS'
2312 !      include 'COMMON.TORSION'
2313 !      include 'COMMON.VECTORS'
2314 !      include 'COMMON.FFIELD'
2315       real(kind=8),dimension(3) :: ggg
2316 !d      write(iout,*) 'In EELEC_soft_sphere'
2317 !el local variables
2318       integer :: i,j,k,num_conti,iteli,itelj
2319       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2320       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2321       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2322
2323       ees=0.0D0
2324       evdw1=0.0D0
2325       eel_loc=0.0d0
2326       eello_turn3=0.0d0
2327       eello_turn4=0.0d0
2328 !el      ind=0
2329       do i=iatel_s,iatel_e
2330         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2331         dxi=dc(1,i)
2332         dyi=dc(2,i)
2333         dzi=dc(3,i)
2334         xmedi=c(1,i)+0.5d0*dxi
2335         ymedi=c(2,i)+0.5d0*dyi
2336         zmedi=c(3,i)+0.5d0*dzi
2337         num_conti=0
2338 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2339         do j=ielstart(i),ielend(i)
2340           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2341 !el          ind=ind+1
2342           iteli=itel(i)
2343           itelj=itel(j)
2344           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2345           r0ij=rpp(iteli,itelj)
2346           r0ijsq=r0ij*r0ij
2347           dxj=dc(1,j)
2348           dyj=dc(2,j)
2349           dzj=dc(3,j)
2350           xj=c(1,j)+0.5D0*dxj-xmedi
2351           yj=c(2,j)+0.5D0*dyj-ymedi
2352           zj=c(3,j)+0.5D0*dzj-zmedi
2353           rij=xj*xj+yj*yj+zj*zj
2354           if (rij.lt.r0ijsq) then
2355             evdw1ij=0.25d0*(rij-r0ijsq)**2
2356             fac=rij-r0ijsq
2357           else
2358             evdw1ij=0.0d0
2359             fac=0.0d0
2360           endif
2361           evdw1=evdw1+evdw1ij
2362 !
2363 ! Calculate contributions to the Cartesian gradient.
2364 !
2365           ggg(1)=fac*xj
2366           ggg(2)=fac*yj
2367           ggg(3)=fac*zj
2368           do k=1,3
2369             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2370             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2371           enddo
2372 !
2373 ! Loop over residues i+1 thru j-1.
2374 !
2375 !grad          do k=i+1,j-1
2376 !grad            do l=1,3
2377 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2378 !grad            enddo
2379 !grad          enddo
2380         enddo ! j
2381       enddo   ! i
2382 !grad      do i=nnt,nct-1
2383 !grad        do k=1,3
2384 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2385 !grad        enddo
2386 !grad        do j=i+1,nct-1
2387 !grad          do k=1,3
2388 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2389 !grad          enddo
2390 !grad        enddo
2391 !grad      enddo
2392       return
2393       end subroutine eelec_soft_sphere
2394 !-----------------------------------------------------------------------------
2395       subroutine vec_and_deriv
2396 !      implicit real*8 (a-h,o-z)
2397 !      include 'DIMENSIONS'
2398 #ifdef MPI
2399       include 'mpif.h'
2400 #endif
2401 !      include 'COMMON.IOUNITS'
2402 !      include 'COMMON.GEO'
2403 !      include 'COMMON.VAR'
2404 !      include 'COMMON.LOCAL'
2405 !      include 'COMMON.CHAIN'
2406 !      include 'COMMON.VECTORS'
2407 !      include 'COMMON.SETUP'
2408 !      include 'COMMON.TIME1'
2409       real(kind=8),dimension(3,3,2) :: uyder,uzder
2410       real(kind=8),dimension(2) :: vbld_inv_temp
2411 ! Compute the local reference systems. For reference system (i), the
2412 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2413 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2414 !el local variables
2415       integer :: i,j,k,l
2416       real(kind=8) :: facy,fac,costh
2417
2418 #ifdef PARVEC
2419       do i=ivec_start,ivec_end
2420 #else
2421       do i=1,nres-1
2422 #endif
2423           if (i.eq.nres-1) then
2424 ! Case of the last full residue
2425 ! Compute the Z-axis
2426             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2427             costh=dcos(pi-theta(nres))
2428             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2429             do k=1,3
2430               uz(k,i)=fac*uz(k,i)
2431             enddo
2432 ! Compute the derivatives of uz
2433             uzder(1,1,1)= 0.0d0
2434             uzder(2,1,1)=-dc_norm(3,i-1)
2435             uzder(3,1,1)= dc_norm(2,i-1)
2436             uzder(1,2,1)= dc_norm(3,i-1)
2437             uzder(2,2,1)= 0.0d0
2438             uzder(3,2,1)=-dc_norm(1,i-1)
2439             uzder(1,3,1)=-dc_norm(2,i-1)
2440             uzder(2,3,1)= dc_norm(1,i-1)
2441             uzder(3,3,1)= 0.0d0
2442             uzder(1,1,2)= 0.0d0
2443             uzder(2,1,2)= dc_norm(3,i)
2444             uzder(3,1,2)=-dc_norm(2,i)
2445             uzder(1,2,2)=-dc_norm(3,i)
2446             uzder(2,2,2)= 0.0d0
2447             uzder(3,2,2)= dc_norm(1,i)
2448             uzder(1,3,2)= dc_norm(2,i)
2449             uzder(2,3,2)=-dc_norm(1,i)
2450             uzder(3,3,2)= 0.0d0
2451 ! Compute the Y-axis
2452             facy=fac
2453             do k=1,3
2454               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2455             enddo
2456 ! Compute the derivatives of uy
2457             do j=1,3
2458               do k=1,3
2459                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2460                               -dc_norm(k,i)*dc_norm(j,i-1)
2461                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2462               enddo
2463               uyder(j,j,1)=uyder(j,j,1)-costh
2464               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2465             enddo
2466             do j=1,2
2467               do k=1,3
2468                 do l=1,3
2469                   uygrad(l,k,j,i)=uyder(l,k,j)
2470                   uzgrad(l,k,j,i)=uzder(l,k,j)
2471                 enddo
2472               enddo
2473             enddo
2474             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2475             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2476             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2477             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2478           else
2479 ! Other residues
2480 ! Compute the Z-axis
2481             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2482             costh=dcos(pi-theta(i+2))
2483             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2484             do k=1,3
2485               uz(k,i)=fac*uz(k,i)
2486             enddo
2487 ! Compute the derivatives of uz
2488             uzder(1,1,1)= 0.0d0
2489             uzder(2,1,1)=-dc_norm(3,i+1)
2490             uzder(3,1,1)= dc_norm(2,i+1)
2491             uzder(1,2,1)= dc_norm(3,i+1)
2492             uzder(2,2,1)= 0.0d0
2493             uzder(3,2,1)=-dc_norm(1,i+1)
2494             uzder(1,3,1)=-dc_norm(2,i+1)
2495             uzder(2,3,1)= dc_norm(1,i+1)
2496             uzder(3,3,1)= 0.0d0
2497             uzder(1,1,2)= 0.0d0
2498             uzder(2,1,2)= dc_norm(3,i)
2499             uzder(3,1,2)=-dc_norm(2,i)
2500             uzder(1,2,2)=-dc_norm(3,i)
2501             uzder(2,2,2)= 0.0d0
2502             uzder(3,2,2)= dc_norm(1,i)
2503             uzder(1,3,2)= dc_norm(2,i)
2504             uzder(2,3,2)=-dc_norm(1,i)
2505             uzder(3,3,2)= 0.0d0
2506 ! Compute the Y-axis
2507             facy=fac
2508             do k=1,3
2509               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2510             enddo
2511 ! Compute the derivatives of uy
2512             do j=1,3
2513               do k=1,3
2514                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2515                               -dc_norm(k,i)*dc_norm(j,i+1)
2516                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2517               enddo
2518               uyder(j,j,1)=uyder(j,j,1)-costh
2519               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2520             enddo
2521             do j=1,2
2522               do k=1,3
2523                 do l=1,3
2524                   uygrad(l,k,j,i)=uyder(l,k,j)
2525                   uzgrad(l,k,j,i)=uzder(l,k,j)
2526                 enddo
2527               enddo
2528             enddo
2529             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2530             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2531             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2532             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2533           endif
2534       enddo
2535       do i=1,nres-1
2536         vbld_inv_temp(1)=vbld_inv(i+1)
2537         if (i.lt.nres-1) then
2538           vbld_inv_temp(2)=vbld_inv(i+2)
2539           else
2540           vbld_inv_temp(2)=vbld_inv(i)
2541           endif
2542         do j=1,2
2543           do k=1,3
2544             do l=1,3
2545               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2546               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2547             enddo
2548           enddo
2549         enddo
2550       enddo
2551 #if defined(PARVEC) && defined(MPI)
2552       if (nfgtasks1.gt.1) then
2553         time00=MPI_Wtime()
2554 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2555 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2556 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2557         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2558          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2559          FG_COMM1,IERR)
2560         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2561          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2562          FG_COMM1,IERR)
2563         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2564          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2565          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2566         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2567          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2568          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2569         time_gather=time_gather+MPI_Wtime()-time00
2570       endif
2571 !      if (fg_rank.eq.0) then
2572 !        write (iout,*) "Arrays UY and UZ"
2573 !        do i=1,nres-1
2574 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2575 !     &     (uz(k,i),k=1,3)
2576 !        enddo
2577 !      endif
2578 #endif
2579       return
2580       end subroutine vec_and_deriv
2581 !-----------------------------------------------------------------------------
2582       subroutine check_vecgrad
2583 !      implicit real*8 (a-h,o-z)
2584 !      include 'DIMENSIONS'
2585 !      include 'COMMON.IOUNITS'
2586 !      include 'COMMON.GEO'
2587 !      include 'COMMON.VAR'
2588 !      include 'COMMON.LOCAL'
2589 !      include 'COMMON.CHAIN'
2590 !      include 'COMMON.VECTORS'
2591       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2592       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2593       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2594       real(kind=8),dimension(3) :: erij
2595       real(kind=8) :: delta=1.0d-7
2596 !el local variables
2597       integer :: i,j,k,l
2598
2599       call vec_and_deriv
2600 !d      do i=1,nres
2601 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2602 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2603 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2604 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2605 !d     &     (dc_norm(if90,i),if90=1,3)
2606 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2607 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2608 !d          write(iout,'(a)')
2609 !d      enddo
2610       do i=1,nres
2611         do j=1,2
2612           do k=1,3
2613             do l=1,3
2614               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2615               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2616             enddo
2617           enddo
2618         enddo
2619       enddo
2620       call vec_and_deriv
2621       do i=1,nres
2622         do j=1,3
2623           uyt(j,i)=uy(j,i)
2624           uzt(j,i)=uz(j,i)
2625         enddo
2626       enddo
2627       do i=1,nres
2628 !d        write (iout,*) 'i=',i
2629         do k=1,3
2630           erij(k)=dc_norm(k,i)
2631         enddo
2632         do j=1,3
2633           do k=1,3
2634             dc_norm(k,i)=erij(k)
2635           enddo
2636           dc_norm(j,i)=dc_norm(j,i)+delta
2637 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2638 !          do k=1,3
2639 !            dc_norm(k,i)=dc_norm(k,i)/fac
2640 !          enddo
2641 !          write (iout,*) (dc_norm(k,i),k=1,3)
2642 !          write (iout,*) (erij(k),k=1,3)
2643           call vec_and_deriv
2644           do k=1,3
2645             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2646             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2647             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2648             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2649           enddo
2650 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2651 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2652 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2653         enddo
2654         do k=1,3
2655           dc_norm(k,i)=erij(k)
2656         enddo
2657 !d        do k=1,3
2658 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2659 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2660 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2661 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2662 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2663 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2664 !d          write (iout,'(a)')
2665 !d        enddo
2666       enddo
2667       return
2668       end subroutine check_vecgrad
2669 !-----------------------------------------------------------------------------
2670       subroutine set_matrices
2671 !      implicit real*8 (a-h,o-z)
2672 !      include 'DIMENSIONS'
2673 #ifdef MPI
2674       include "mpif.h"
2675 !      include "COMMON.SETUP"
2676       integer :: IERR
2677       integer :: status(MPI_STATUS_SIZE)
2678 #endif
2679 !      include 'COMMON.IOUNITS'
2680 !      include 'COMMON.GEO'
2681 !      include 'COMMON.VAR'
2682 !      include 'COMMON.LOCAL'
2683 !      include 'COMMON.CHAIN'
2684 !      include 'COMMON.DERIV'
2685 !      include 'COMMON.INTERACT'
2686 !      include 'COMMON.CONTACTS'
2687 !      include 'COMMON.TORSION'
2688 !      include 'COMMON.VECTORS'
2689 !      include 'COMMON.FFIELD'
2690       real(kind=8) :: auxvec(2),auxmat(2,2)
2691       integer :: i,iti1,iti,k,l
2692       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2693 !       print *,"in set matrices"
2694 !
2695 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2696 ! to calculate the el-loc multibody terms of various order.
2697 !
2698 !AL el      mu=0.0d0
2699 #ifdef PARMAT
2700       do i=ivec_start+2,ivec_end+2
2701 #else
2702       do i=3,nres+1
2703 #endif
2704 !      print *,i,"i"
2705         if (i .lt. nres+1) then
2706           sin1=dsin(phi(i))
2707           cos1=dcos(phi(i))
2708           sintab(i-2)=sin1
2709           costab(i-2)=cos1
2710           obrot(1,i-2)=cos1
2711           obrot(2,i-2)=sin1
2712           sin2=dsin(2*phi(i))
2713           cos2=dcos(2*phi(i))
2714           sintab2(i-2)=sin2
2715           costab2(i-2)=cos2
2716           obrot2(1,i-2)=cos2
2717           obrot2(2,i-2)=sin2
2718           Ug(1,1,i-2)=-cos1
2719           Ug(1,2,i-2)=-sin1
2720           Ug(2,1,i-2)=-sin1
2721           Ug(2,2,i-2)= cos1
2722           Ug2(1,1,i-2)=-cos2
2723           Ug2(1,2,i-2)=-sin2
2724           Ug2(2,1,i-2)=-sin2
2725           Ug2(2,2,i-2)= cos2
2726         else
2727           costab(i-2)=1.0d0
2728           sintab(i-2)=0.0d0
2729           obrot(1,i-2)=1.0d0
2730           obrot(2,i-2)=0.0d0
2731           obrot2(1,i-2)=0.0d0
2732           obrot2(2,i-2)=0.0d0
2733           Ug(1,1,i-2)=1.0d0
2734           Ug(1,2,i-2)=0.0d0
2735           Ug(2,1,i-2)=0.0d0
2736           Ug(2,2,i-2)=1.0d0
2737           Ug2(1,1,i-2)=0.0d0
2738           Ug2(1,2,i-2)=0.0d0
2739           Ug2(2,1,i-2)=0.0d0
2740           Ug2(2,2,i-2)=0.0d0
2741         endif
2742         if (i .gt. 3 .and. i .lt. nres+1) then
2743           obrot_der(1,i-2)=-sin1
2744           obrot_der(2,i-2)= cos1
2745           Ugder(1,1,i-2)= sin1
2746           Ugder(1,2,i-2)=-cos1
2747           Ugder(2,1,i-2)=-cos1
2748           Ugder(2,2,i-2)=-sin1
2749           dwacos2=cos2+cos2
2750           dwasin2=sin2+sin2
2751           obrot2_der(1,i-2)=-dwasin2
2752           obrot2_der(2,i-2)= dwacos2
2753           Ug2der(1,1,i-2)= dwasin2
2754           Ug2der(1,2,i-2)=-dwacos2
2755           Ug2der(2,1,i-2)=-dwacos2
2756           Ug2der(2,2,i-2)=-dwasin2
2757         else
2758           obrot_der(1,i-2)=0.0d0
2759           obrot_der(2,i-2)=0.0d0
2760           Ugder(1,1,i-2)=0.0d0
2761           Ugder(1,2,i-2)=0.0d0
2762           Ugder(2,1,i-2)=0.0d0
2763           Ugder(2,2,i-2)=0.0d0
2764           obrot2_der(1,i-2)=0.0d0
2765           obrot2_der(2,i-2)=0.0d0
2766           Ug2der(1,1,i-2)=0.0d0
2767           Ug2der(1,2,i-2)=0.0d0
2768           Ug2der(2,1,i-2)=0.0d0
2769           Ug2der(2,2,i-2)=0.0d0
2770         endif
2771 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2772         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2773            if (itype(i-2,1).eq.0) then
2774           iti=ntortyp+1
2775            else
2776           iti = itortyp(itype(i-2,1))
2777            endif
2778         else
2779           iti=ntortyp+1
2780         endif
2781 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2782         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2783            if (itype(i-1,1).eq.0) then
2784           iti1=ntortyp+1
2785            else
2786           iti1 = itortyp(itype(i-1,1))
2787            endif
2788         else
2789           iti1=ntortyp+1
2790         endif
2791 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2792 !d        write (iout,*) '*******i',i,' iti1',iti
2793 !d        write (iout,*) 'b1',b1(:,iti)
2794 !d        write (iout,*) 'b2',b2(:,iti)
2795 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2796 !        if (i .gt. iatel_s+2) then
2797         if (i .gt. nnt+2) then
2798           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2799           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2800           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2801           then
2802           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2803           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2804           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2805           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2806           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2807           endif
2808         else
2809           do k=1,2
2810             Ub2(k,i-2)=0.0d0
2811             Ctobr(k,i-2)=0.0d0
2812             Dtobr2(k,i-2)=0.0d0
2813             do l=1,2
2814               EUg(l,k,i-2)=0.0d0
2815               CUg(l,k,i-2)=0.0d0
2816               DUg(l,k,i-2)=0.0d0
2817               DtUg2(l,k,i-2)=0.0d0
2818             enddo
2819           enddo
2820         endif
2821         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2822         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2823         do k=1,2
2824           muder(k,i-2)=Ub2der(k,i-2)
2825         enddo
2826 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2827         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2828           if (itype(i-1,1).eq.0) then
2829            iti1=ntortyp+1
2830           elseif (itype(i-1,1).le.ntyp) then
2831             iti1 = itortyp(itype(i-1,1))
2832           else
2833             iti1=ntortyp+1
2834           endif
2835         else
2836           iti1=ntortyp+1
2837         endif
2838         do k=1,2
2839           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2840         enddo
2841 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2842 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2843 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2844 !d        write (iout,*) 'mu1',mu1(:,i-2)
2845 !d        write (iout,*) 'mu2',mu2(:,i-2)
2846         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2847         then
2848         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2849         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2850         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2851         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2852         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2853 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2854         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2855         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2856         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2857         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2858         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2859         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2860         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2861         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2862         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2863         endif
2864       enddo
2865 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2866 ! The order of matrices is from left to right.
2867       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2868       then
2869 !      do i=max0(ivec_start,2),ivec_end
2870       do i=2,nres-1
2871         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2872         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2873         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2874         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2875         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2876         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2877         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2878         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2879       enddo
2880       endif
2881 #if defined(MPI) && defined(PARMAT)
2882 #ifdef DEBUG
2883 !      if (fg_rank.eq.0) then
2884         write (iout,*) "Arrays UG and UGDER before GATHER"
2885         do i=1,nres-1
2886           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2887            ((ug(l,k,i),l=1,2),k=1,2),&
2888            ((ugder(l,k,i),l=1,2),k=1,2)
2889         enddo
2890         write (iout,*) "Arrays UG2 and UG2DER"
2891         do i=1,nres-1
2892           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2893            ((ug2(l,k,i),l=1,2),k=1,2),&
2894            ((ug2der(l,k,i),l=1,2),k=1,2)
2895         enddo
2896         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2897         do i=1,nres-1
2898           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2899            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2900            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2901         enddo
2902         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2903         do i=1,nres-1
2904           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2905            costab(i),sintab(i),costab2(i),sintab2(i)
2906         enddo
2907         write (iout,*) "Array MUDER"
2908         do i=1,nres-1
2909           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2910         enddo
2911 !      endif
2912 #endif
2913       if (nfgtasks.gt.1) then
2914         time00=MPI_Wtime()
2915 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2916 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2917 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2918 #ifdef MATGATHER
2919         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2920          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2921          FG_COMM1,IERR)
2922         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2923          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2924          FG_COMM1,IERR)
2925         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2926          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2927          FG_COMM1,IERR)
2928         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2929          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2930          FG_COMM1,IERR)
2931         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2932          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2933          FG_COMM1,IERR)
2934         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2935          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2936          FG_COMM1,IERR)
2937         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2938          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2939          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2940         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2941          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2942          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2943         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2944          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2945          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2946         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2947          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2948          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2949         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2950         then
2951         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2952          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2953          FG_COMM1,IERR)
2954         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2955          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2956          FG_COMM1,IERR)
2957         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2958          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2959          FG_COMM1,IERR)
2960        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2961          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2962          FG_COMM1,IERR)
2963         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2964          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2965          FG_COMM1,IERR)
2966         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2967          ivec_count(fg_rank1),&
2968          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2969          FG_COMM1,IERR)
2970         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2971          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2972          FG_COMM1,IERR)
2973         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2974          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2975          FG_COMM1,IERR)
2976         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2977          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2978          FG_COMM1,IERR)
2979         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2980          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2981          FG_COMM1,IERR)
2982         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2983          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2984          FG_COMM1,IERR)
2985         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2986          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2987          FG_COMM1,IERR)
2988         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2989          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2990          FG_COMM1,IERR)
2991         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2992          ivec_count(fg_rank1),&
2993          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2994          FG_COMM1,IERR)
2995         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2996          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2997          FG_COMM1,IERR)
2998        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2999          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3000          FG_COMM1,IERR)
3001         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
3002          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3003          FG_COMM1,IERR)
3004        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
3005          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3006          FG_COMM1,IERR)
3007         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
3008          ivec_count(fg_rank1),&
3009          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3010          FG_COMM1,IERR)
3011         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
3012          ivec_count(fg_rank1),&
3013          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
3014          FG_COMM1,IERR)
3015         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
3016          ivec_count(fg_rank1),&
3017          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3018          MPI_MAT2,FG_COMM1,IERR)
3019         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
3020          ivec_count(fg_rank1),&
3021          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
3022          MPI_MAT2,FG_COMM1,IERR)
3023         endif
3024 #else
3025 ! Passes matrix info through the ring
3026       isend=fg_rank1
3027       irecv=fg_rank1-1
3028       if (irecv.lt.0) irecv=nfgtasks1-1
3029       iprev=irecv
3030       inext=fg_rank1+1
3031       if (inext.ge.nfgtasks1) inext=0
3032       do i=1,nfgtasks1-1
3033 !        write (iout,*) "isend",isend," irecv",irecv
3034 !        call flush(iout)
3035         lensend=lentyp(isend)
3036         lenrecv=lentyp(irecv)
3037 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3038 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3039 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
3040 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3041 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
3042 !        write (iout,*) "Gather ROTAT1"
3043 !        call flush(iout)
3044 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3045 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
3046 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3047 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
3048 !        write (iout,*) "Gather ROTAT2"
3049 !        call flush(iout)
3050         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
3051          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
3052          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
3053          iprev,4400+irecv,FG_COMM,status,IERR)
3054 !        write (iout,*) "Gather ROTAT_OLD"
3055 !        call flush(iout)
3056         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
3057          MPI_PRECOMP11(lensend),inext,5500+isend,&
3058          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
3059          iprev,5500+irecv,FG_COMM,status,IERR)
3060 !        write (iout,*) "Gather PRECOMP11"
3061 !        call flush(iout)
3062         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
3063          MPI_PRECOMP12(lensend),inext,6600+isend,&
3064          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
3065          iprev,6600+irecv,FG_COMM,status,IERR)
3066 !        write (iout,*) "Gather PRECOMP12"
3067 !        call flush(iout)
3068         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
3069         then
3070         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
3071          MPI_ROTAT2(lensend),inext,7700+isend,&
3072          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
3073          iprev,7700+irecv,FG_COMM,status,IERR)
3074 !        write (iout,*) "Gather PRECOMP21"
3075 !        call flush(iout)
3076         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
3077          MPI_PRECOMP22(lensend),inext,8800+isend,&
3078          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
3079          iprev,8800+irecv,FG_COMM,status,IERR)
3080 !        write (iout,*) "Gather PRECOMP22"
3081 !        call flush(iout)
3082         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
3083          MPI_PRECOMP23(lensend),inext,9900+isend,&
3084          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
3085          MPI_PRECOMP23(lenrecv),&
3086          iprev,9900+irecv,FG_COMM,status,IERR)
3087 !        write (iout,*) "Gather PRECOMP23"
3088 !        call flush(iout)
3089         endif
3090         isend=irecv
3091         irecv=irecv-1
3092         if (irecv.lt.0) irecv=nfgtasks1-1
3093       enddo
3094 #endif
3095         time_gather=time_gather+MPI_Wtime()-time00
3096       endif
3097 #ifdef DEBUG
3098 !      if (fg_rank.eq.0) then
3099         write (iout,*) "Arrays UG and UGDER"
3100         do i=1,nres-1
3101           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3102            ((ug(l,k,i),l=1,2),k=1,2),&
3103            ((ugder(l,k,i),l=1,2),k=1,2)
3104         enddo
3105         write (iout,*) "Arrays UG2 and UG2DER"
3106         do i=1,nres-1
3107           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3108            ((ug2(l,k,i),l=1,2),k=1,2),&
3109            ((ug2der(l,k,i),l=1,2),k=1,2)
3110         enddo
3111         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3112         do i=1,nres-1
3113           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3114            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
3115            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3116         enddo
3117         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3118         do i=1,nres-1
3119           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
3120            costab(i),sintab(i),costab2(i),sintab2(i)
3121         enddo
3122         write (iout,*) "Array MUDER"
3123         do i=1,nres-1
3124           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3125         enddo
3126 !      endif
3127 #endif
3128 #endif
3129 !d      do i=1,nres
3130 !d        iti = itortyp(itype(i,1))
3131 !d        write (iout,*) i
3132 !d        do j=1,2
3133 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3134 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3135 !d        enddo
3136 !d      enddo
3137       return
3138       end subroutine set_matrices
3139 !-----------------------------------------------------------------------------
3140       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3141 !
3142 ! This subroutine calculates the average interaction energy and its gradient
3143 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
3144 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3145 ! The potential depends both on the distance of peptide-group centers and on
3146 ! the orientation of the CA-CA virtual bonds.
3147 !
3148       use comm_locel
3149 !      implicit real*8 (a-h,o-z)
3150 #ifdef MPI
3151       include 'mpif.h'
3152 #endif
3153 !      include 'DIMENSIONS'
3154 !      include 'COMMON.CONTROL'
3155 !      include 'COMMON.SETUP'
3156 !      include 'COMMON.IOUNITS'
3157 !      include 'COMMON.GEO'
3158 !      include 'COMMON.VAR'
3159 !      include 'COMMON.LOCAL'
3160 !      include 'COMMON.CHAIN'
3161 !      include 'COMMON.DERIV'
3162 !      include 'COMMON.INTERACT'
3163 !      include 'COMMON.CONTACTS'
3164 !      include 'COMMON.TORSION'
3165 !      include 'COMMON.VECTORS'
3166 !      include 'COMMON.FFIELD'
3167 !      include 'COMMON.TIME1'
3168       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
3169       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3170       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3171 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3172       real(kind=8),dimension(4) :: muij
3173 !el      integer :: num_conti,j1,j2
3174 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3175 !el        dz_normi,xmedi,ymedi,zmedi
3176
3177 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3178 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3179 !el          num_conti,j1,j2
3180
3181 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3182 #ifdef MOMENT
3183       real(kind=8) :: scal_el=1.0d0
3184 #else
3185       real(kind=8) :: scal_el=0.5d0
3186 #endif
3187 ! 12/13/98
3188 ! 13-go grudnia roku pamietnego...
3189       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3190                                              0.0d0,1.0d0,0.0d0,&
3191                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3192 !el local variables
3193       integer :: i,k,j
3194       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3195       real(kind=8) :: fac,t_eelecij,fracinbuf
3196
3197
3198 !d      write(iout,*) 'In EELEC'
3199 !        print *,"IN EELEC"
3200 !d      do i=1,nloctyp
3201 !d        write(iout,*) 'Type',i
3202 !d        write(iout,*) 'B1',B1(:,i)
3203 !d        write(iout,*) 'B2',B2(:,i)
3204 !d        write(iout,*) 'CC',CC(:,:,i)
3205 !d        write(iout,*) 'DD',DD(:,:,i)
3206 !d        write(iout,*) 'EE',EE(:,:,i)
3207 !d      enddo
3208 !d      call check_vecgrad
3209 !d      stop
3210 !      ees=0.0d0  !AS
3211 !      evdw1=0.0d0
3212 !      eel_loc=0.0d0
3213 !      eello_turn3=0.0d0
3214 !      eello_turn4=0.0d0
3215       t_eelecij=0.0d0
3216       ees=0.0D0
3217       evdw1=0.0D0
3218       eel_loc=0.0d0
3219       eello_turn3=0.0d0
3220       eello_turn4=0.0d0
3221 !
3222
3223       if (icheckgrad.eq.1) then
3224 !el
3225 !        do i=0,2*nres+2
3226 !          dc_norm(1,i)=0.0d0
3227 !          dc_norm(2,i)=0.0d0
3228 !          dc_norm(3,i)=0.0d0
3229 !        enddo
3230         do i=1,nres-1
3231           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3232           do k=1,3
3233             dc_norm(k,i)=dc(k,i)*fac
3234           enddo
3235 !          write (iout,*) 'i',i,' fac',fac
3236         enddo
3237       endif
3238 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3239 !        wturn6
3240       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3241           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3242           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3243 !        call vec_and_deriv
3244 #ifdef TIMING
3245         time01=MPI_Wtime()
3246 #endif
3247 !        print *, "before set matrices"
3248         call set_matrices
3249 !        print *, "after set matrices"
3250
3251 #ifdef TIMING
3252         time_mat=time_mat+MPI_Wtime()-time01
3253 #endif
3254       endif
3255 !       print *, "after set matrices"
3256 !d      do i=1,nres-1
3257 !d        write (iout,*) 'i=',i
3258 !d        do k=1,3
3259 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3260 !d        enddo
3261 !d        do k=1,3
3262 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3263 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3264 !d        enddo
3265 !d      enddo
3266       t_eelecij=0.0d0
3267       ees=0.0D0
3268       evdw1=0.0D0
3269       eel_loc=0.0d0
3270       eello_turn3=0.0d0
3271       eello_turn4=0.0d0
3272 !el      ind=0
3273       do i=1,nres
3274         num_cont_hb(i)=0
3275       enddo
3276 !d      print '(a)','Enter EELEC'
3277 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3278 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3279 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3280       do i=1,nres
3281         gel_loc_loc(i)=0.0d0
3282         gcorr_loc(i)=0.0d0
3283       enddo
3284 !
3285 !
3286 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3287 !
3288 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3289 !
3290
3291
3292 !        print *,"before iturn3 loop"
3293       do i=iturn3_start,iturn3_end
3294         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3295         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3296         dxi=dc(1,i)
3297         dyi=dc(2,i)
3298         dzi=dc(3,i)
3299         dx_normi=dc_norm(1,i)
3300         dy_normi=dc_norm(2,i)
3301         dz_normi=dc_norm(3,i)
3302         xmedi=c(1,i)+0.5d0*dxi
3303         ymedi=c(2,i)+0.5d0*dyi
3304         zmedi=c(3,i)+0.5d0*dzi
3305           xmedi=dmod(xmedi,boxxsize)
3306           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3307           ymedi=dmod(ymedi,boxysize)
3308           if (ymedi.lt.0) ymedi=ymedi+boxysize
3309           zmedi=dmod(zmedi,boxzsize)
3310           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3311         num_conti=0
3312        if ((zmedi.gt.bordlipbot) &
3313         .and.(zmedi.lt.bordliptop)) then
3314 !C the energy transfer exist
3315         if (zmedi.lt.buflipbot) then
3316 !C what fraction I am in
3317          fracinbuf=1.0d0- &
3318                ((zmedi-bordlipbot)/lipbufthick)
3319 !C lipbufthick is thickenes of lipid buffore
3320          sslipi=sscalelip(fracinbuf)
3321          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3322         elseif (zmedi.gt.bufliptop) then
3323          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3324          sslipi=sscalelip(fracinbuf)
3325          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3326         else
3327          sslipi=1.0d0
3328          ssgradlipi=0.0
3329         endif
3330        else
3331          sslipi=0.0d0
3332          ssgradlipi=0.0
3333        endif
3334 !       print *,i,sslipi,ssgradlipi
3335        call eelecij(i,i+2,ees,evdw1,eel_loc)
3336         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3337         num_cont_hb(i)=num_conti
3338       enddo
3339       do i=iturn4_start,iturn4_end
3340         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3341           .or. itype(i+3,1).eq.ntyp1 &
3342           .or. itype(i+4,1).eq.ntyp1) cycle
3343 !        print *,"before2",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3344         dxi=dc(1,i)
3345         dyi=dc(2,i)
3346         dzi=dc(3,i)
3347         dx_normi=dc_norm(1,i)
3348         dy_normi=dc_norm(2,i)
3349         dz_normi=dc_norm(3,i)
3350         xmedi=c(1,i)+0.5d0*dxi
3351         ymedi=c(2,i)+0.5d0*dyi
3352         zmedi=c(3,i)+0.5d0*dzi
3353           xmedi=dmod(xmedi,boxxsize)
3354           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3355           ymedi=dmod(ymedi,boxysize)
3356           if (ymedi.lt.0) ymedi=ymedi+boxysize
3357           zmedi=dmod(zmedi,boxzsize)
3358           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3359        if ((zmedi.gt.bordlipbot)  &
3360        .and.(zmedi.lt.bordliptop)) then
3361 !C the energy transfer exist
3362         if (zmedi.lt.buflipbot) then
3363 !C what fraction I am in
3364          fracinbuf=1.0d0- &
3365              ((zmedi-bordlipbot)/lipbufthick)
3366 !C lipbufthick is thickenes of lipid buffore
3367          sslipi=sscalelip(fracinbuf)
3368          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3369         elseif (zmedi.gt.bufliptop) then
3370          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3371          sslipi=sscalelip(fracinbuf)
3372          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3373         else
3374          sslipi=1.0d0
3375          ssgradlipi=0.0
3376         endif
3377        else
3378          sslipi=0.0d0
3379          ssgradlipi=0.0
3380        endif
3381
3382         num_conti=num_cont_hb(i)
3383         call eelecij(i,i+3,ees,evdw1,eel_loc)
3384         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3385          call eturn4(i,eello_turn4)
3386 !        print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3387         num_cont_hb(i)=num_conti
3388       enddo   ! i
3389 !
3390 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3391 !
3392 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3393       do i=iatel_s,iatel_e
3394         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3395         dxi=dc(1,i)
3396         dyi=dc(2,i)
3397         dzi=dc(3,i)
3398         dx_normi=dc_norm(1,i)
3399         dy_normi=dc_norm(2,i)
3400         dz_normi=dc_norm(3,i)
3401         xmedi=c(1,i)+0.5d0*dxi
3402         ymedi=c(2,i)+0.5d0*dyi
3403         zmedi=c(3,i)+0.5d0*dzi
3404           xmedi=dmod(xmedi,boxxsize)
3405           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3406           ymedi=dmod(ymedi,boxysize)
3407           if (ymedi.lt.0) ymedi=ymedi+boxysize
3408           zmedi=dmod(zmedi,boxzsize)
3409           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3410        if ((zmedi.gt.bordlipbot)  &
3411         .and.(zmedi.lt.bordliptop)) then
3412 !C the energy transfer exist
3413         if (zmedi.lt.buflipbot) then
3414 !C what fraction I am in
3415          fracinbuf=1.0d0- &
3416              ((zmedi-bordlipbot)/lipbufthick)
3417 !C lipbufthick is thickenes of lipid buffore
3418          sslipi=sscalelip(fracinbuf)
3419          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3420         elseif (zmedi.gt.bufliptop) then
3421          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3422          sslipi=sscalelip(fracinbuf)
3423          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3424         else
3425          sslipi=1.0d0
3426          ssgradlipi=0.0
3427         endif
3428        else
3429          sslipi=0.0d0
3430          ssgradlipi=0.0
3431        endif
3432
3433 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3434         num_conti=num_cont_hb(i)
3435         do j=ielstart(i),ielend(i)
3436 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3437           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3438           call eelecij(i,j,ees,evdw1,eel_loc)
3439         enddo ! j
3440         num_cont_hb(i)=num_conti
3441       enddo   ! i
3442 !      write (iout,*) "Number of loop steps in EELEC:",ind
3443 !d      do i=1,nres
3444 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3445 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3446 !d      enddo
3447 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3448 !cc      eel_loc=eel_loc+eello_turn3
3449 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3450       return
3451       end subroutine eelec
3452 !-----------------------------------------------------------------------------
3453       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3454
3455       use comm_locel
3456 !      implicit real*8 (a-h,o-z)
3457 !      include 'DIMENSIONS'
3458 #ifdef MPI
3459       include "mpif.h"
3460 #endif
3461 !      include 'COMMON.CONTROL'
3462 !      include 'COMMON.IOUNITS'
3463 !      include 'COMMON.GEO'
3464 !      include 'COMMON.VAR'
3465 !      include 'COMMON.LOCAL'
3466 !      include 'COMMON.CHAIN'
3467 !      include 'COMMON.DERIV'
3468 !      include 'COMMON.INTERACT'
3469 !      include 'COMMON.CONTACTS'
3470 !      include 'COMMON.TORSION'
3471 !      include 'COMMON.VECTORS'
3472 !      include 'COMMON.FFIELD'
3473 !      include 'COMMON.TIME1'
3474       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3475       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3476       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3477 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3478       real(kind=8),dimension(4) :: muij
3479       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3480                     dist_temp, dist_init,rlocshield,fracinbuf
3481       integer xshift,yshift,zshift,ilist,iresshield
3482 !el      integer :: num_conti,j1,j2
3483 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3484 !el        dz_normi,xmedi,ymedi,zmedi
3485
3486 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3487 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3488 !el          num_conti,j1,j2
3489
3490 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3491 #ifdef MOMENT
3492       real(kind=8) :: scal_el=1.0d0
3493 #else
3494       real(kind=8) :: scal_el=0.5d0
3495 #endif
3496 ! 12/13/98
3497 ! 13-go grudnia roku pamietnego...
3498       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3499                                              0.0d0,1.0d0,0.0d0,&
3500                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3501 !      integer :: maxconts=nres/4
3502 !el local variables
3503       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3504       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3505       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3506       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3507                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3508                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3509                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3510                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3511                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3512                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3513                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3514 !      maxconts=nres/4
3515 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3516 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3517
3518 !          time00=MPI_Wtime()
3519 !d      write (iout,*) "eelecij",i,j
3520 !          ind=ind+1
3521           iteli=itel(i)
3522           itelj=itel(j)
3523           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3524           aaa=app(iteli,itelj)
3525           bbb=bpp(iteli,itelj)
3526           ael6i=ael6(iteli,itelj)
3527           ael3i=ael3(iteli,itelj)
3528           dxj=dc(1,j)
3529           dyj=dc(2,j)
3530           dzj=dc(3,j)
3531           dx_normj=dc_norm(1,j)
3532           dy_normj=dc_norm(2,j)
3533           dz_normj=dc_norm(3,j)
3534 !          xj=c(1,j)+0.5D0*dxj-xmedi
3535 !          yj=c(2,j)+0.5D0*dyj-ymedi
3536 !          zj=c(3,j)+0.5D0*dzj-zmedi
3537           xj=c(1,j)+0.5D0*dxj
3538           yj=c(2,j)+0.5D0*dyj
3539           zj=c(3,j)+0.5D0*dzj
3540           xj=mod(xj,boxxsize)
3541           if (xj.lt.0) xj=xj+boxxsize
3542           yj=mod(yj,boxysize)
3543           if (yj.lt.0) yj=yj+boxysize
3544           zj=mod(zj,boxzsize)
3545           if (zj.lt.0) zj=zj+boxzsize
3546        if ((zj.gt.bordlipbot)  &
3547        .and.(zj.lt.bordliptop)) then
3548 !C the energy transfer exist
3549         if (zj.lt.buflipbot) then
3550 !C what fraction I am in
3551          fracinbuf=1.0d0-     &
3552              ((zj-bordlipbot)/lipbufthick)
3553 !C lipbufthick is thickenes of lipid buffore
3554          sslipj=sscalelip(fracinbuf)
3555          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3556         elseif (zj.gt.bufliptop) then
3557          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3558          sslipj=sscalelip(fracinbuf)
3559          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3560         else
3561          sslipj=1.0d0
3562          ssgradlipj=0.0
3563         endif
3564        else
3565          sslipj=0.0d0
3566          ssgradlipj=0.0
3567        endif
3568
3569       isubchap=0
3570       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3571       xj_safe=xj
3572       yj_safe=yj
3573       zj_safe=zj
3574       do xshift=-1,1
3575       do yshift=-1,1
3576       do zshift=-1,1
3577           xj=xj_safe+xshift*boxxsize
3578           yj=yj_safe+yshift*boxysize
3579           zj=zj_safe+zshift*boxzsize
3580           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3581           if(dist_temp.lt.dist_init) then
3582             dist_init=dist_temp
3583             xj_temp=xj
3584             yj_temp=yj
3585             zj_temp=zj
3586             isubchap=1
3587           endif
3588        enddo
3589        enddo
3590        enddo
3591        if (isubchap.eq.1) then
3592 !C          print *,i,j
3593           xj=xj_temp-xmedi
3594           yj=yj_temp-ymedi
3595           zj=zj_temp-zmedi
3596        else
3597           xj=xj_safe-xmedi
3598           yj=yj_safe-ymedi
3599           zj=zj_safe-zmedi
3600        endif
3601
3602           rij=xj*xj+yj*yj+zj*zj
3603           rrmij=1.0D0/rij
3604           rij=dsqrt(rij)
3605 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3606             sss_ele_cut=sscale_ele(rij)
3607             sss_ele_grad=sscagrad_ele(rij)
3608 !             sss_ele_cut=1.0d0
3609 !             sss_ele_grad=0.0d0
3610 !            print *,sss_ele_cut,sss_ele_grad,&
3611 !            (rij),r_cut_ele,rlamb_ele
3612 !            if (sss_ele_cut.le.0.0) go to 128
3613
3614           rmij=1.0D0/rij
3615           r3ij=rrmij*rmij
3616           r6ij=r3ij*r3ij
3617           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3618           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3619           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3620           fac=cosa-3.0D0*cosb*cosg
3621           ev1=aaa*r6ij*r6ij
3622 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3623           if (j.eq.i+2) ev1=scal_el*ev1
3624           ev2=bbb*r6ij
3625           fac3=ael6i*r6ij
3626           fac4=ael3i*r3ij
3627           evdwij=ev1+ev2
3628           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3629           el2=fac4*fac
3630 !          eesij=el1+el2
3631           if (shield_mode.gt.0) then
3632 !C          fac_shield(i)=0.4
3633 !C          fac_shield(j)=0.6
3634           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3635           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3636           eesij=(el1+el2)
3637           ees=ees+eesij*sss_ele_cut
3638 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3639 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3640           else
3641           fac_shield(i)=1.0
3642           fac_shield(j)=1.0
3643           eesij=(el1+el2)
3644           ees=ees+eesij   &
3645             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3646 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3647           endif
3648
3649 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3650           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3651 !          ees=ees+eesij*sss_ele_cut
3652           evdw1=evdw1+evdwij*sss_ele_cut  &
3653            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3654 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3655 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3656 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3657 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3658
3659           if (energy_dec) then
3660 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3661 !                  'evdw1',i,j,evdwij,&
3662 !                  iteli,itelj,aaa,evdw1
3663               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3664               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3665           endif
3666 !
3667 ! Calculate contributions to the Cartesian gradient.
3668 !
3669 #ifdef SPLITELE
3670           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3671               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3672           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3673              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3674           fac1=fac
3675           erij(1)=xj*rmij
3676           erij(2)=yj*rmij
3677           erij(3)=zj*rmij
3678 !
3679 ! Radial derivatives. First process both termini of the fragment (i,j)
3680 !
3681           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3682           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3683           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3684            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3685           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3686             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3687
3688           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3689           (shield_mode.gt.0)) then
3690 !C          print *,i,j
3691           do ilist=1,ishield_list(i)
3692            iresshield=shield_list(ilist,i)
3693            do k=1,3
3694            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3695            *2.0*sss_ele_cut
3696            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3697                    rlocshield &
3698             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3699             *sss_ele_cut
3700             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3701            enddo
3702           enddo
3703           do ilist=1,ishield_list(j)
3704            iresshield=shield_list(ilist,j)
3705            do k=1,3
3706            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3707           *2.0*sss_ele_cut
3708            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3709                    rlocshield &
3710            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3711            *sss_ele_cut
3712            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3713            enddo
3714           enddo
3715           do k=1,3
3716             gshieldc(k,i)=gshieldc(k,i)+ &
3717                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3718            *sss_ele_cut
3719
3720             gshieldc(k,j)=gshieldc(k,j)+ &
3721                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3722            *sss_ele_cut
3723
3724             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3725                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3726            *sss_ele_cut
3727
3728             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3729                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3730            *sss_ele_cut
3731
3732            enddo
3733            endif
3734
3735
3736 !          do k=1,3
3737 !            ghalf=0.5D0*ggg(k)
3738 !            gelc(k,i)=gelc(k,i)+ghalf
3739 !            gelc(k,j)=gelc(k,j)+ghalf
3740 !          enddo
3741 ! 9/28/08 AL Gradient compotents will be summed only at the end
3742           do k=1,3
3743             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3744             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3745           enddo
3746             gelc_long(3,j)=gelc_long(3,j)+  &
3747           ssgradlipj*eesij/2.0d0*lipscale**2&
3748            *sss_ele_cut
3749
3750             gelc_long(3,i)=gelc_long(3,i)+  &
3751           ssgradlipi*eesij/2.0d0*lipscale**2&
3752            *sss_ele_cut
3753
3754
3755 !
3756 ! Loop over residues i+1 thru j-1.
3757 !
3758 !grad          do k=i+1,j-1
3759 !grad            do l=1,3
3760 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3761 !grad            enddo
3762 !grad          enddo
3763           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3764            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3765           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3766            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3767           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3768            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3769
3770 !          do k=1,3
3771 !            ghalf=0.5D0*ggg(k)
3772 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3773 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3774 !          enddo
3775 ! 9/28/08 AL Gradient compotents will be summed only at the end
3776           do k=1,3
3777             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3778             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3779           enddo
3780
3781 !C Lipidic part for scaling weight
3782            gvdwpp(3,j)=gvdwpp(3,j)+ &
3783           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3784            gvdwpp(3,i)=gvdwpp(3,i)+ &
3785           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3786 !! Loop over residues i+1 thru j-1.
3787 !
3788 !grad          do k=i+1,j-1
3789 !grad            do l=1,3
3790 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3791 !grad            enddo
3792 !grad          enddo
3793 #else
3794           facvdw=(ev1+evdwij)*sss_ele_cut &
3795            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3796
3797           facel=(el1+eesij)*sss_ele_cut
3798           fac1=fac
3799           fac=-3*rrmij*(facvdw+facvdw+facel)
3800           erij(1)=xj*rmij
3801           erij(2)=yj*rmij
3802           erij(3)=zj*rmij
3803 !
3804 ! Radial derivatives. First process both termini of the fragment (i,j)
3805 !
3806           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3807           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3808           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3809 !          do k=1,3
3810 !            ghalf=0.5D0*ggg(k)
3811 !            gelc(k,i)=gelc(k,i)+ghalf
3812 !            gelc(k,j)=gelc(k,j)+ghalf
3813 !          enddo
3814 ! 9/28/08 AL Gradient compotents will be summed only at the end
3815           do k=1,3
3816             gelc_long(k,j)=gelc(k,j)+ggg(k)
3817             gelc_long(k,i)=gelc(k,i)-ggg(k)
3818           enddo
3819 !
3820 ! Loop over residues i+1 thru j-1.
3821 !
3822 !grad          do k=i+1,j-1
3823 !grad            do l=1,3
3824 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3825 !grad            enddo
3826 !grad          enddo
3827 ! 9/28/08 AL Gradient compotents will be summed only at the end
3828           ggg(1)=facvdw*xj &
3829            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3830           ggg(2)=facvdw*yj &
3831            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3832           ggg(3)=facvdw*zj &
3833            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3834
3835           do k=1,3
3836             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3837             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3838           enddo
3839            gvdwpp(3,j)=gvdwpp(3,j)+ &
3840           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3841            gvdwpp(3,i)=gvdwpp(3,i)+ &
3842           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3843
3844 #endif
3845 !
3846 ! Angular part
3847 !
3848           ecosa=2.0D0*fac3*fac1+fac4
3849           fac4=-3.0D0*fac4
3850           fac3=-6.0D0*fac3
3851           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3852           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3853           do k=1,3
3854             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3855             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3856           enddo
3857 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3858 !d   &          (dcosg(k),k=1,3)
3859           do k=1,3
3860             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3861              *fac_shield(i)**2*fac_shield(j)**2 &
3862              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3863
3864           enddo
3865 !          do k=1,3
3866 !            ghalf=0.5D0*ggg(k)
3867 !            gelc(k,i)=gelc(k,i)+ghalf
3868 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3869 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3870 !            gelc(k,j)=gelc(k,j)+ghalf
3871 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3872 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3873 !          enddo
3874 !grad          do k=i+1,j-1
3875 !grad            do l=1,3
3876 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3877 !grad            enddo
3878 !grad          enddo
3879           do k=1,3
3880             gelc(k,i)=gelc(k,i) &
3881                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3882                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3883                      *sss_ele_cut &
3884                      *fac_shield(i)**2*fac_shield(j)**2 &
3885                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3886
3887             gelc(k,j)=gelc(k,j) &
3888                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3889                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3890                      *sss_ele_cut  &
3891                      *fac_shield(i)**2*fac_shield(j)**2  &
3892                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3893
3894             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3895             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3896           enddo
3897
3898           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3899               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3900               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3901 !
3902 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3903 !   energy of a peptide unit is assumed in the form of a second-order
3904 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3905 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3906 !   are computed for EVERY pair of non-contiguous peptide groups.
3907 !
3908           if (j.lt.nres-1) then
3909             j1=j+1
3910             j2=j-1
3911           else
3912             j1=j-1
3913             j2=j-2
3914           endif
3915           kkk=0
3916           do k=1,2
3917             do l=1,2
3918               kkk=kkk+1
3919               muij(kkk)=mu(k,i)*mu(l,j)
3920             enddo
3921           enddo
3922 !d         write (iout,*) 'EELEC: i',i,' j',j
3923 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3924 !d          write(iout,*) 'muij',muij
3925           ury=scalar(uy(1,i),erij)
3926           urz=scalar(uz(1,i),erij)
3927           vry=scalar(uy(1,j),erij)
3928           vrz=scalar(uz(1,j),erij)
3929           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3930           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3931           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3932           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3933           fac=dsqrt(-ael6i)*r3ij
3934           a22=a22*fac
3935           a23=a23*fac
3936           a32=a32*fac
3937           a33=a33*fac
3938 !d          write (iout,'(4i5,4f10.5)')
3939 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
3940 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3941 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3942 !d     &      uy(:,j),uz(:,j)
3943 !d          write (iout,'(4f10.5)')
3944 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3945 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3946 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3947 !d           write (iout,'(9f10.5/)')
3948 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3949 ! Derivatives of the elements of A in virtual-bond vectors
3950           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3951           do k=1,3
3952             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3953             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3954             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3955             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3956             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3957             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3958             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3959             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3960             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3961             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3962             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3963             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3964           enddo
3965 ! Compute radial contributions to the gradient
3966           facr=-3.0d0*rrmij
3967           a22der=a22*facr
3968           a23der=a23*facr
3969           a32der=a32*facr
3970           a33der=a33*facr
3971           agg(1,1)=a22der*xj
3972           agg(2,1)=a22der*yj
3973           agg(3,1)=a22der*zj
3974           agg(1,2)=a23der*xj
3975           agg(2,2)=a23der*yj
3976           agg(3,2)=a23der*zj
3977           agg(1,3)=a32der*xj
3978           agg(2,3)=a32der*yj
3979           agg(3,3)=a32der*zj
3980           agg(1,4)=a33der*xj
3981           agg(2,4)=a33der*yj
3982           agg(3,4)=a33der*zj
3983 ! Add the contributions coming from er
3984           fac3=-3.0d0*fac
3985           do k=1,3
3986             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3987             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3988             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3989             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3990           enddo
3991           do k=1,3
3992 ! Derivatives in DC(i)
3993 !grad            ghalf1=0.5d0*agg(k,1)
3994 !grad            ghalf2=0.5d0*agg(k,2)
3995 !grad            ghalf3=0.5d0*agg(k,3)
3996 !grad            ghalf4=0.5d0*agg(k,4)
3997             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3998             -3.0d0*uryg(k,2)*vry)!+ghalf1
3999             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
4000             -3.0d0*uryg(k,2)*vrz)!+ghalf2
4001             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
4002             -3.0d0*urzg(k,2)*vry)!+ghalf3
4003             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
4004             -3.0d0*urzg(k,2)*vrz)!+ghalf4
4005 ! Derivatives in DC(i+1)
4006             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
4007             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4008             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
4009             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4010             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
4011             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4012             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
4013             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4014 ! Derivatives in DC(j)
4015             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
4016             -3.0d0*vryg(k,2)*ury)!+ghalf1
4017             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
4018             -3.0d0*vrzg(k,2)*ury)!+ghalf2
4019             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
4020             -3.0d0*vryg(k,2)*urz)!+ghalf3
4021             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
4022             -3.0d0*vrzg(k,2)*urz)!+ghalf4
4023 ! Derivatives in DC(j+1) or DC(nres-1)
4024             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
4025             -3.0d0*vryg(k,3)*ury)
4026             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
4027             -3.0d0*vrzg(k,3)*ury)
4028             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
4029             -3.0d0*vryg(k,3)*urz)
4030             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
4031             -3.0d0*vrzg(k,3)*urz)
4032 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
4033 !grad              do l=1,4
4034 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4035 !grad              enddo
4036 !grad            endif
4037           enddo
4038           acipa(1,1)=a22
4039           acipa(1,2)=a23
4040           acipa(2,1)=a32
4041           acipa(2,2)=a33
4042           a22=-a22
4043           a23=-a23
4044           do l=1,2
4045             do k=1,3
4046               agg(k,l)=-agg(k,l)
4047               aggi(k,l)=-aggi(k,l)
4048               aggi1(k,l)=-aggi1(k,l)
4049               aggj(k,l)=-aggj(k,l)
4050               aggj1(k,l)=-aggj1(k,l)
4051             enddo
4052           enddo
4053           if (j.lt.nres-1) then
4054             a22=-a22
4055             a32=-a32
4056             do l=1,3,2
4057               do k=1,3
4058                 agg(k,l)=-agg(k,l)
4059                 aggi(k,l)=-aggi(k,l)
4060                 aggi1(k,l)=-aggi1(k,l)
4061                 aggj(k,l)=-aggj(k,l)
4062                 aggj1(k,l)=-aggj1(k,l)
4063               enddo
4064             enddo
4065           else
4066             a22=-a22
4067             a23=-a23
4068             a32=-a32
4069             a33=-a33
4070             do l=1,4
4071               do k=1,3
4072                 agg(k,l)=-agg(k,l)
4073                 aggi(k,l)=-aggi(k,l)
4074                 aggi1(k,l)=-aggi1(k,l)
4075                 aggj(k,l)=-aggj(k,l)
4076                 aggj1(k,l)=-aggj1(k,l)
4077               enddo
4078             enddo
4079           endif
4080           ENDIF ! WCORR
4081           IF (wel_loc.gt.0.0d0) THEN
4082 ! Contribution to the local-electrostatic energy coming from the i-j pair
4083           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
4084            +a33*muij(4)
4085           if (shield_mode.eq.0) then
4086            fac_shield(i)=1.0
4087            fac_shield(j)=1.0
4088           endif
4089           eel_loc_ij=eel_loc_ij &
4090          *fac_shield(i)*fac_shield(j) &
4091          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4092 !C Now derivative over eel_loc
4093           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
4094          (shield_mode.gt.0)) then
4095 !C          print *,i,j
4096
4097           do ilist=1,ishield_list(i)
4098            iresshield=shield_list(ilist,i)
4099            do k=1,3
4100            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
4101                                                 /fac_shield(i)&
4102            *sss_ele_cut
4103            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4104                    rlocshield  &
4105           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
4106           *sss_ele_cut
4107
4108             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4109            +rlocshield
4110            enddo
4111           enddo
4112           do ilist=1,ishield_list(j)
4113            iresshield=shield_list(ilist,j)
4114            do k=1,3
4115            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
4116                                             /fac_shield(j)   &
4117             *sss_ele_cut
4118            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
4119                    rlocshield  &
4120       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
4121        *sss_ele_cut
4122
4123            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
4124                   +rlocshield
4125
4126            enddo
4127           enddo
4128
4129           do k=1,3
4130             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
4131                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4132                     *sss_ele_cut
4133             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
4134                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4135                     *sss_ele_cut
4136             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
4137                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
4138                     *sss_ele_cut
4139             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
4140                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
4141                     *sss_ele_cut
4142
4143            enddo
4144            endif
4145
4146
4147 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4148 !           eel_loc_ij=0.0
4149 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4150 !                  'eelloc',i,j,eel_loc_ij
4151           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
4152                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4153 !           print *,"EELLOC",i,gel_loc_loc(i-1)
4154
4155 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4156 !          if (energy_dec) write (iout,*) "muij",muij
4157 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
4158
4159           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
4160 ! Partial derivatives in virtual-bond dihedral angles gamma
4161           if (i.gt.1) &
4162           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
4163                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
4164                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
4165                  *sss_ele_cut  &
4166           *fac_shield(i)*fac_shield(j) &
4167           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4168
4169           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
4170                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
4171                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
4172                  *sss_ele_cut &
4173           *fac_shield(i)*fac_shield(j) &
4174           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4175 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4176 !          do l=1,3
4177 !            ggg(1)=(agg(1,1)*muij(1)+ &
4178 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
4179 !            *sss_ele_cut &
4180 !             +eel_loc_ij*sss_ele_grad*rmij*xj
4181 !            ggg(2)=(agg(2,1)*muij(1)+ &
4182 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4183 !            *sss_ele_cut &
4184 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4185 !            ggg(3)=(agg(3,1)*muij(1)+ &
4186 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4187 !            *sss_ele_cut &
4188 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4189            xtemp(1)=xj
4190            xtemp(2)=yj
4191            xtemp(3)=zj
4192
4193            do l=1,3
4194             ggg(l)=(agg(l,1)*muij(1)+ &
4195                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4196             *sss_ele_cut &
4197           *fac_shield(i)*fac_shield(j) &
4198           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4199              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4200
4201
4202             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4203             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4204 !grad            ghalf=0.5d0*ggg(l)
4205 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4206 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4207           enddo
4208             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4209           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4210           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4211
4212             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4213           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4214           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4215
4216 !grad          do k=i+1,j2
4217 !grad            do l=1,3
4218 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4219 !grad            enddo
4220 !grad          enddo
4221 ! Remaining derivatives of eello
4222           do l=1,3
4223             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4224                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4225             *sss_ele_cut &
4226           *fac_shield(i)*fac_shield(j) &
4227           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4228
4229 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4230             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4231                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4232             +aggi1(l,4)*muij(4))&
4233             *sss_ele_cut &
4234           *fac_shield(i)*fac_shield(j) &
4235           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4236
4237 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4238             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4239                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4240             *sss_ele_cut &
4241           *fac_shield(i)*fac_shield(j) &
4242           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4243
4244 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4245             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4246                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4247             +aggj1(l,4)*muij(4))&
4248             *sss_ele_cut &
4249           *fac_shield(i)*fac_shield(j) &
4250          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4251
4252 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4253           enddo
4254           ENDIF
4255 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4256 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4257           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4258              .and. num_conti.le.maxconts) then
4259 !            write (iout,*) i,j," entered corr"
4260 !
4261 ! Calculate the contact function. The ith column of the array JCONT will
4262 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4263 ! greater than I). The arrays FACONT and GACONT will contain the values of
4264 ! the contact function and its derivative.
4265 !           r0ij=1.02D0*rpp(iteli,itelj)
4266 !           r0ij=1.11D0*rpp(iteli,itelj)
4267             r0ij=2.20D0*rpp(iteli,itelj)
4268 !           r0ij=1.55D0*rpp(iteli,itelj)
4269             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4270 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4271             if (fcont.gt.0.0D0) then
4272               num_conti=num_conti+1
4273               if (num_conti.gt.maxconts) then
4274 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4275 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4276                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4277                                ' will skip next contacts for this conf.', num_conti
4278               else
4279                 jcont_hb(num_conti,i)=j
4280 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4281 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4282                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4283                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4284 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4285 !  terms.
4286                 d_cont(num_conti,i)=rij
4287 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4288 !     --- Electrostatic-interaction matrix ---
4289                 a_chuj(1,1,num_conti,i)=a22
4290                 a_chuj(1,2,num_conti,i)=a23
4291                 a_chuj(2,1,num_conti,i)=a32
4292                 a_chuj(2,2,num_conti,i)=a33
4293 !     --- Gradient of rij
4294                 do kkk=1,3
4295                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4296                 enddo
4297                 kkll=0
4298                 do k=1,2
4299                   do l=1,2
4300                     kkll=kkll+1
4301                     do m=1,3
4302                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4303                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4304                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4305                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4306                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4307                     enddo
4308                   enddo
4309                 enddo
4310                 ENDIF
4311                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4312 ! Calculate contact energies
4313                 cosa4=4.0D0*cosa
4314                 wij=cosa-3.0D0*cosb*cosg
4315                 cosbg1=cosb+cosg
4316                 cosbg2=cosb-cosg
4317 !               fac3=dsqrt(-ael6i)/r0ij**3
4318                 fac3=dsqrt(-ael6i)*r3ij
4319 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4320                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4321                 if (ees0tmp.gt.0) then
4322                   ees0pij=dsqrt(ees0tmp)
4323                 else
4324                   ees0pij=0
4325                 endif
4326                 if (shield_mode.eq.0) then
4327                 fac_shield(i)=1.0d0
4328                 fac_shield(j)=1.0d0
4329                 else
4330                 ees0plist(num_conti,i)=j
4331                 endif
4332 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4333                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4334                 if (ees0tmp.gt.0) then
4335                   ees0mij=dsqrt(ees0tmp)
4336                 else
4337                   ees0mij=0
4338                 endif
4339 !               ees0mij=0.0D0
4340                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4341                      *sss_ele_cut &
4342                      *fac_shield(i)*fac_shield(j)
4343
4344                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4345                      *sss_ele_cut &
4346                      *fac_shield(i)*fac_shield(j)
4347
4348 ! Diagnostics. Comment out or remove after debugging!
4349 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4350 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4351 !               ees0m(num_conti,i)=0.0D0
4352 ! End diagnostics.
4353 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4354 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4355 ! Angular derivatives of the contact function
4356                 ees0pij1=fac3/ees0pij
4357                 ees0mij1=fac3/ees0mij
4358                 fac3p=-3.0D0*fac3*rrmij
4359                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4360                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4361 !               ees0mij1=0.0D0
4362                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4363                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4364                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4365                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4366                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4367                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4368                 ecosap=ecosa1+ecosa2
4369                 ecosbp=ecosb1+ecosb2
4370                 ecosgp=ecosg1+ecosg2
4371                 ecosam=ecosa1-ecosa2
4372                 ecosbm=ecosb1-ecosb2
4373                 ecosgm=ecosg1-ecosg2
4374 ! Diagnostics
4375 !               ecosap=ecosa1
4376 !               ecosbp=ecosb1
4377 !               ecosgp=ecosg1
4378 !               ecosam=0.0D0
4379 !               ecosbm=0.0D0
4380 !               ecosgm=0.0D0
4381 ! End diagnostics
4382                 facont_hb(num_conti,i)=fcont
4383                 fprimcont=fprimcont/rij
4384 !d              facont_hb(num_conti,i)=1.0D0
4385 ! Following line is for diagnostics.
4386 !d              fprimcont=0.0D0
4387                 do k=1,3
4388                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4389                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4390                 enddo
4391                 do k=1,3
4392                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4393                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4394                 enddo
4395                 gggp(1)=gggp(1)+ees0pijp*xj &
4396                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4397                 gggp(2)=gggp(2)+ees0pijp*yj &
4398                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4399                 gggp(3)=gggp(3)+ees0pijp*zj &
4400                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4401
4402                 gggm(1)=gggm(1)+ees0mijp*xj &
4403                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4404
4405                 gggm(2)=gggm(2)+ees0mijp*yj &
4406                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4407
4408                 gggm(3)=gggm(3)+ees0mijp*zj &
4409                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4410
4411 ! Derivatives due to the contact function
4412                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4413                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4414                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4415                 do k=1,3
4416 !
4417 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4418 !          following the change of gradient-summation algorithm.
4419 !
4420 !grad                  ghalfp=0.5D0*gggp(k)
4421 !grad                  ghalfm=0.5D0*gggm(k)
4422                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4423                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4424                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4425                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4426
4427                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4428                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4429                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4430                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4431
4432                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4433                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4434
4435                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4436                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4437                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4438                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4439
4440                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4441                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4442                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4443                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4444
4445                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4446                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4447
4448                 enddo
4449 ! Diagnostics. Comment out or remove after debugging!
4450 !diag           do k=1,3
4451 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4452 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4453 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4454 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4455 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4456 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4457 !diag           enddo
4458               ENDIF ! wcorr
4459               endif  ! num_conti.le.maxconts
4460             endif  ! fcont.gt.0
4461           endif    ! j.gt.i+1
4462           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4463             do k=1,4
4464               do l=1,3
4465                 ghalf=0.5d0*agg(l,k)
4466                 aggi(l,k)=aggi(l,k)+ghalf
4467                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4468                 aggj(l,k)=aggj(l,k)+ghalf
4469               enddo
4470             enddo
4471             if (j.eq.nres-1 .and. i.lt.j-2) then
4472               do k=1,4
4473                 do l=1,3
4474                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4475                 enddo
4476               enddo
4477             endif
4478           endif
4479  128  continue
4480 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4481       return
4482       end subroutine eelecij
4483 !-----------------------------------------------------------------------------
4484       subroutine eturn3(i,eello_turn3)
4485 ! Third- and fourth-order contributions from turns
4486
4487       use comm_locel
4488 !      implicit real*8 (a-h,o-z)
4489 !      include 'DIMENSIONS'
4490 !      include 'COMMON.IOUNITS'
4491 !      include 'COMMON.GEO'
4492 !      include 'COMMON.VAR'
4493 !      include 'COMMON.LOCAL'
4494 !      include 'COMMON.CHAIN'
4495 !      include 'COMMON.DERIV'
4496 !      include 'COMMON.INTERACT'
4497 !      include 'COMMON.CONTACTS'
4498 !      include 'COMMON.TORSION'
4499 !      include 'COMMON.VECTORS'
4500 !      include 'COMMON.FFIELD'
4501 !      include 'COMMON.CONTROL'
4502       real(kind=8),dimension(3) :: ggg
4503       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4504         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4505       real(kind=8),dimension(2) :: auxvec,auxvec1
4506 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4507       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4508 !el      integer :: num_conti,j1,j2
4509 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4510 !el        dz_normi,xmedi,ymedi,zmedi
4511
4512 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4513 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4514 !el         num_conti,j1,j2
4515 !el local variables
4516       integer :: i,j,l,k,ilist,iresshield
4517       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4518
4519       j=i+2
4520 !      write (iout,*) "eturn3",i,j,j1,j2
4521           zj=(c(3,j)+c(3,j+1))/2.0d0
4522           zj=mod(zj,boxzsize)
4523           if (zj.lt.0) zj=zj+boxzsize
4524           if ((zj.lt.0)) write (*,*) "CHUJ"
4525        if ((zj.gt.bordlipbot)  &
4526         .and.(zj.lt.bordliptop)) then
4527 !C the energy transfer exist
4528         if (zj.lt.buflipbot) then
4529 !C what fraction I am in
4530          fracinbuf=1.0d0-     &
4531              ((zj-bordlipbot)/lipbufthick)
4532 !C lipbufthick is thickenes of lipid buffore
4533          sslipj=sscalelip(fracinbuf)
4534          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4535         elseif (zj.gt.bufliptop) then
4536          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4537          sslipj=sscalelip(fracinbuf)
4538          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4539         else
4540          sslipj=1.0d0
4541          ssgradlipj=0.0
4542         endif
4543        else
4544          sslipj=0.0d0
4545          ssgradlipj=0.0
4546        endif
4547
4548       a_temp(1,1)=a22
4549       a_temp(1,2)=a23
4550       a_temp(2,1)=a32
4551       a_temp(2,2)=a33
4552 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4553 !
4554 !               Third-order contributions
4555 !
4556 !                 (i+2)o----(i+3)
4557 !                      | |
4558 !                      | |
4559 !                 (i+1)o----i
4560 !
4561 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4562 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4563         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4564         call transpose2(auxmat(1,1),auxmat1(1,1))
4565         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4566         if (shield_mode.eq.0) then
4567         fac_shield(i)=1.0d0
4568         fac_shield(j)=1.0d0
4569         endif
4570
4571         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4572          *fac_shield(i)*fac_shield(j)  &
4573          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4574         eello_t3= &
4575         0.5d0*(pizda(1,1)+pizda(2,2)) &
4576         *fac_shield(i)*fac_shield(j)
4577
4578         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4579                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4580           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4581        (shield_mode.gt.0)) then
4582 !C          print *,i,j
4583
4584           do ilist=1,ishield_list(i)
4585            iresshield=shield_list(ilist,i)
4586            do k=1,3
4587            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4588            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4589                    rlocshield &
4590            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4591             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4592              +rlocshield
4593            enddo
4594           enddo
4595           do ilist=1,ishield_list(j)
4596            iresshield=shield_list(ilist,j)
4597            do k=1,3
4598            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4599            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4600                    rlocshield &
4601            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4602            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4603                   +rlocshield
4604
4605            enddo
4606           enddo
4607
4608           do k=1,3
4609             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4610                    grad_shield(k,i)*eello_t3/fac_shield(i)
4611             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4612                    grad_shield(k,j)*eello_t3/fac_shield(j)
4613             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4614                    grad_shield(k,i)*eello_t3/fac_shield(i)
4615             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4616                    grad_shield(k,j)*eello_t3/fac_shield(j)
4617            enddo
4618            endif
4619
4620 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4621 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4622 !d     &    ' eello_turn3_num',4*eello_turn3_num
4623 ! Derivatives in gamma(i)
4624         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4625         call transpose2(auxmat2(1,1),auxmat3(1,1))
4626         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4627         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4628           *fac_shield(i)*fac_shield(j)        &
4629           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4630 ! Derivatives in gamma(i+1)
4631         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4632         call transpose2(auxmat2(1,1),auxmat3(1,1))
4633         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4634         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4635           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4636           *fac_shield(i)*fac_shield(j)        &
4637           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4638
4639 ! Cartesian derivatives
4640         do l=1,3
4641 !            ghalf1=0.5d0*agg(l,1)
4642 !            ghalf2=0.5d0*agg(l,2)
4643 !            ghalf3=0.5d0*agg(l,3)
4644 !            ghalf4=0.5d0*agg(l,4)
4645           a_temp(1,1)=aggi(l,1)!+ghalf1
4646           a_temp(1,2)=aggi(l,2)!+ghalf2
4647           a_temp(2,1)=aggi(l,3)!+ghalf3
4648           a_temp(2,2)=aggi(l,4)!+ghalf4
4649           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4650           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4651             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4652           *fac_shield(i)*fac_shield(j)      &
4653           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4654
4655           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4656           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4657           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4658           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4659           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4660           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4661             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4662           *fac_shield(i)*fac_shield(j)        &
4663           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4664
4665           a_temp(1,1)=aggj(l,1)!+ghalf1
4666           a_temp(1,2)=aggj(l,2)!+ghalf2
4667           a_temp(2,1)=aggj(l,3)!+ghalf3
4668           a_temp(2,2)=aggj(l,4)!+ghalf4
4669           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4670           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4671             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4672           *fac_shield(i)*fac_shield(j)      &
4673           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4674
4675           a_temp(1,1)=aggj1(l,1)
4676           a_temp(1,2)=aggj1(l,2)
4677           a_temp(2,1)=aggj1(l,3)
4678           a_temp(2,2)=aggj1(l,4)
4679           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4680           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4681             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4682           *fac_shield(i)*fac_shield(j)        &
4683           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4684         enddo
4685          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4686           ssgradlipi*eello_t3/4.0d0*lipscale
4687          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4688           ssgradlipj*eello_t3/4.0d0*lipscale
4689          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4690           ssgradlipi*eello_t3/4.0d0*lipscale
4691          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4692           ssgradlipj*eello_t3/4.0d0*lipscale
4693
4694       return
4695       end subroutine eturn3
4696 !-----------------------------------------------------------------------------
4697       subroutine eturn4(i,eello_turn4)
4698 ! Third- and fourth-order contributions from turns
4699
4700       use comm_locel
4701 !      implicit real*8 (a-h,o-z)
4702 !      include 'DIMENSIONS'
4703 !      include 'COMMON.IOUNITS'
4704 !      include 'COMMON.GEO'
4705 !      include 'COMMON.VAR'
4706 !      include 'COMMON.LOCAL'
4707 !      include 'COMMON.CHAIN'
4708 !      include 'COMMON.DERIV'
4709 !      include 'COMMON.INTERACT'
4710 !      include 'COMMON.CONTACTS'
4711 !      include 'COMMON.TORSION'
4712 !      include 'COMMON.VECTORS'
4713 !      include 'COMMON.FFIELD'
4714 !      include 'COMMON.CONTROL'
4715       real(kind=8),dimension(3) :: ggg
4716       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4717         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4718       real(kind=8),dimension(2) :: auxvec,auxvec1
4719 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4720       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4721 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4722 !el        dz_normi,xmedi,ymedi,zmedi
4723 !el      integer :: num_conti,j1,j2
4724 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4725 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4726 !el          num_conti,j1,j2
4727 !el local variables
4728       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4729       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4730          rlocshield
4731
4732       j=i+3
4733 !      if (j.ne.20) return
4734 !      print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1)
4735 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4736 !
4737 !               Fourth-order contributions
4738 !
4739 !                 (i+3)o----(i+4)
4740 !                     /  |
4741 !               (i+2)o   |
4742 !                     \  |
4743 !                 (i+1)o----i
4744 !
4745 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4746 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4747 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4748           zj=(c(3,j)+c(3,j+1))/2.0d0
4749           zj=mod(zj,boxzsize)
4750           if (zj.lt.0) zj=zj+boxzsize
4751        if ((zj.gt.bordlipbot)  &
4752         .and.(zj.lt.bordliptop)) then
4753 !C the energy transfer exist
4754         if (zj.lt.buflipbot) then
4755 !C what fraction I am in
4756          fracinbuf=1.0d0-     &
4757              ((zj-bordlipbot)/lipbufthick)
4758 !C lipbufthick is thickenes of lipid buffore
4759          sslipj=sscalelip(fracinbuf)
4760          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4761         elseif (zj.gt.bufliptop) then
4762          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4763          sslipj=sscalelip(fracinbuf)
4764          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4765         else
4766          sslipj=1.0d0
4767          ssgradlipj=0.0
4768         endif
4769        else
4770          sslipj=0.0d0
4771          ssgradlipj=0.0
4772        endif
4773
4774         a_temp(1,1)=a22
4775         a_temp(1,2)=a23
4776         a_temp(2,1)=a32
4777         a_temp(2,2)=a33
4778         iti1=itortyp(itype(i+1,1))
4779         iti2=itortyp(itype(i+2,1))
4780         iti3=itortyp(itype(i+3,1))
4781 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4782         call transpose2(EUg(1,1,i+1),e1t(1,1))
4783         call transpose2(Eug(1,1,i+2),e2t(1,1))
4784         call transpose2(Eug(1,1,i+3),e3t(1,1))
4785         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4786         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4787         s1=scalar2(b1(1,iti2),auxvec(1))
4788         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4789         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4790         s2=scalar2(b1(1,iti1),auxvec(1))
4791         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4792         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4793         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4794         if (shield_mode.eq.0) then
4795         fac_shield(i)=1.0
4796         fac_shield(j)=1.0
4797         endif
4798
4799         eello_turn4=eello_turn4-(s1+s2+s3) &
4800         *fac_shield(i)*fac_shield(j)       &
4801         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4802         eello_t4=-(s1+s2+s3)  &
4803           *fac_shield(i)*fac_shield(j)
4804 !C Now derivative over shield:
4805           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4806          (shield_mode.gt.0)) then
4807 !C          print *,i,j
4808
4809           do ilist=1,ishield_list(i)
4810            iresshield=shield_list(ilist,i)
4811            do k=1,3
4812            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4813 !           print *,"rlocshield",rlocshield,grad_shield_side(k,ilist,i),iresshield
4814            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4815                    rlocshield &
4816             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4817             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4818            +rlocshield
4819            enddo
4820           enddo
4821           do ilist=1,ishield_list(j)
4822            iresshield=shield_list(ilist,j)
4823            do k=1,3
4824 !           print *,"rlocshieldj",j,rlocshield,grad_shield_side(k,ilist,j),iresshield
4825            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4826            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4827                    rlocshield  &
4828            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4829            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4830                   +rlocshield
4831 !            print *,"after", gshieldc_t4(k,iresshield-1),iresshield-1,gshieldc_t4(k,iresshield)
4832
4833            enddo
4834           enddo
4835           do k=1,3
4836             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
4837                    grad_shield(k,i)*eello_t4/fac_shield(i)
4838             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
4839                    grad_shield(k,j)*eello_t4/fac_shield(j)
4840             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
4841                    grad_shield(k,i)*eello_t4/fac_shield(i)
4842             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
4843                    grad_shield(k,j)*eello_t4/fac_shield(j)
4844 !           print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1)
4845            enddo
4846            endif
4847
4848         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4849            'eturn4',i,j,-(s1+s2+s3)
4850 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4851 !d     &    ' eello_turn4_num',8*eello_turn4_num
4852 ! Derivatives in gamma(i)
4853         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4854         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4855         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4856         s1=scalar2(b1(1,iti2),auxvec(1))
4857         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4858         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4859         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
4860        *fac_shield(i)*fac_shield(j)  &
4861        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4862
4863 ! Derivatives in gamma(i+1)
4864         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4865         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4866         s2=scalar2(b1(1,iti1),auxvec(1))
4867         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4868         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4869         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4870         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
4871        *fac_shield(i)*fac_shield(j)  &
4872        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4873
4874 ! Derivatives in gamma(i+2)
4875         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4876         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4877         s1=scalar2(b1(1,iti2),auxvec(1))
4878         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4879         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4880         s2=scalar2(b1(1,iti1),auxvec(1))
4881         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4882         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4883         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4884         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
4885        *fac_shield(i)*fac_shield(j)  &
4886        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4887
4888 ! Cartesian derivatives
4889 ! Derivatives of this turn contributions in DC(i+2)
4890         if (j.lt.nres-1) then
4891           do l=1,3
4892             a_temp(1,1)=agg(l,1)
4893             a_temp(1,2)=agg(l,2)
4894             a_temp(2,1)=agg(l,3)
4895             a_temp(2,2)=agg(l,4)
4896             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4897             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4898             s1=scalar2(b1(1,iti2),auxvec(1))
4899             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4900             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4901             s2=scalar2(b1(1,iti1),auxvec(1))
4902             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4903             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4904             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4905             ggg(l)=-(s1+s2+s3)
4906             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
4907        *fac_shield(i)*fac_shield(j)  &
4908        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4909
4910           enddo
4911         endif
4912 ! Remaining derivatives of this turn contribution
4913         do l=1,3
4914           a_temp(1,1)=aggi(l,1)
4915           a_temp(1,2)=aggi(l,2)
4916           a_temp(2,1)=aggi(l,3)
4917           a_temp(2,2)=aggi(l,4)
4918           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4919           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4920           s1=scalar2(b1(1,iti2),auxvec(1))
4921           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4922           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4923           s2=scalar2(b1(1,iti1),auxvec(1))
4924           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4925           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4926           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4927           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
4928          *fac_shield(i)*fac_shield(j)  &
4929          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4930
4931
4932           a_temp(1,1)=aggi1(l,1)
4933           a_temp(1,2)=aggi1(l,2)
4934           a_temp(2,1)=aggi1(l,3)
4935           a_temp(2,2)=aggi1(l,4)
4936           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4937           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4938           s1=scalar2(b1(1,iti2),auxvec(1))
4939           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4940           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4941           s2=scalar2(b1(1,iti1),auxvec(1))
4942           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4943           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4944           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4945           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
4946          *fac_shield(i)*fac_shield(j)  &
4947          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4948
4949
4950           a_temp(1,1)=aggj(l,1)
4951           a_temp(1,2)=aggj(l,2)
4952           a_temp(2,1)=aggj(l,3)
4953           a_temp(2,2)=aggj(l,4)
4954           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4955           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4956           s1=scalar2(b1(1,iti2),auxvec(1))
4957           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4958           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4959           s2=scalar2(b1(1,iti1),auxvec(1))
4960           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4961           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4962           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4963 !        if (j.lt.nres-1) then
4964           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
4965          *fac_shield(i)*fac_shield(j)  &
4966          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4967 !        endif
4968
4969           a_temp(1,1)=aggj1(l,1)
4970           a_temp(1,2)=aggj1(l,2)
4971           a_temp(2,1)=aggj1(l,3)
4972           a_temp(2,2)=aggj1(l,4)
4973           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4974           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4975           s1=scalar2(b1(1,iti2),auxvec(1))
4976           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4977           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4978           s2=scalar2(b1(1,iti1),auxvec(1))
4979           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4980           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4981           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4982 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4983 !        if (j.lt.nres-1) then
4984 !          print *,"juest before",j1, gcorr4_turn(l,j1)
4985           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
4986          *fac_shield(i)*fac_shield(j)  &
4987          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4988 !            if (shield_mode.gt.0) then
4989 !             print *,"juest after",j1, gcorr4_turn(l,j1),gshieldc_t4(k,j1),gshieldc_loc_t4(k,j1),gel_loc_turn4(i+2)
4990 !            else
4991 !             print *,"juest after",j1, gcorr4_turn(l,j1),gel_loc_turn4(i+2)
4992 !            endif
4993 !         endif
4994         enddo
4995          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
4996           ssgradlipi*eello_t4/4.0d0*lipscale
4997          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
4998           ssgradlipj*eello_t4/4.0d0*lipscale
4999          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
5000           ssgradlipi*eello_t4/4.0d0*lipscale
5001          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
5002           ssgradlipj*eello_t4/4.0d0*lipscale
5003
5004       return
5005       end subroutine eturn4
5006 !-----------------------------------------------------------------------------
5007       subroutine unormderiv(u,ugrad,unorm,ungrad)
5008 ! This subroutine computes the derivatives of a normalized vector u, given
5009 ! the derivatives computed without normalization conditions, ugrad. Returns
5010 ! ungrad.
5011 !      implicit none
5012       real(kind=8),dimension(3) :: u,vec
5013       real(kind=8),dimension(3,3) ::ugrad,ungrad
5014       real(kind=8) :: unorm      !,scalar
5015       integer :: i,j
5016 !      write (2,*) 'ugrad',ugrad
5017 !      write (2,*) 'u',u
5018       do i=1,3
5019         vec(i)=scalar(ugrad(1,i),u(1))
5020       enddo
5021 !      write (2,*) 'vec',vec
5022       do i=1,3
5023         do j=1,3
5024           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5025         enddo
5026       enddo
5027 !      write (2,*) 'ungrad',ungrad
5028       return
5029       end subroutine unormderiv
5030 !-----------------------------------------------------------------------------
5031       subroutine escp_soft_sphere(evdw2,evdw2_14)
5032 !
5033 ! This subroutine calculates the excluded-volume interaction energy between
5034 ! peptide-group centers and side chains and its gradient in virtual-bond and
5035 ! side-chain vectors.
5036 !
5037 !      implicit real*8 (a-h,o-z)
5038 !      include 'DIMENSIONS'
5039 !      include 'COMMON.GEO'
5040 !      include 'COMMON.VAR'
5041 !      include 'COMMON.LOCAL'
5042 !      include 'COMMON.CHAIN'
5043 !      include 'COMMON.DERIV'
5044 !      include 'COMMON.INTERACT'
5045 !      include 'COMMON.FFIELD'
5046 !      include 'COMMON.IOUNITS'
5047 !      include 'COMMON.CONTROL'
5048       real(kind=8),dimension(3) :: ggg
5049 !el local variables
5050       integer :: i,iint,j,k,iteli,itypj
5051       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
5052                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
5053
5054       evdw2=0.0D0
5055       evdw2_14=0.0d0
5056       r0_scp=4.5d0
5057 !d    print '(a)','Enter ESCP'
5058 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5059       do i=iatscp_s,iatscp_e
5060         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5061         iteli=itel(i)
5062         xi=0.5D0*(c(1,i)+c(1,i+1))
5063         yi=0.5D0*(c(2,i)+c(2,i+1))
5064         zi=0.5D0*(c(3,i)+c(3,i+1))
5065
5066         do iint=1,nscp_gr(i)
5067
5068         do j=iscpstart(i,iint),iscpend(i,iint)
5069           if (itype(j,1).eq.ntyp1) cycle
5070           itypj=iabs(itype(j,1))
5071 ! Uncomment following three lines for SC-p interactions
5072 !         xj=c(1,nres+j)-xi
5073 !         yj=c(2,nres+j)-yi
5074 !         zj=c(3,nres+j)-zi
5075 ! Uncomment following three lines for Ca-p interactions
5076           xj=c(1,j)-xi
5077           yj=c(2,j)-yi
5078           zj=c(3,j)-zi
5079           rij=xj*xj+yj*yj+zj*zj
5080           r0ij=r0_scp
5081           r0ijsq=r0ij*r0ij
5082           if (rij.lt.r0ijsq) then
5083             evdwij=0.25d0*(rij-r0ijsq)**2
5084             fac=rij-r0ijsq
5085           else
5086             evdwij=0.0d0
5087             fac=0.0d0
5088           endif
5089           evdw2=evdw2+evdwij
5090 !
5091 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5092 !
5093           ggg(1)=xj*fac
5094           ggg(2)=yj*fac
5095           ggg(3)=zj*fac
5096 !grad          if (j.lt.i) then
5097 !d          write (iout,*) 'j<i'
5098 ! Uncomment following three lines for SC-p interactions
5099 !           do k=1,3
5100 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5101 !           enddo
5102 !grad          else
5103 !d          write (iout,*) 'j>i'
5104 !grad            do k=1,3
5105 !grad              ggg(k)=-ggg(k)
5106 ! Uncomment following line for SC-p interactions
5107 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5108 !grad            enddo
5109 !grad          endif
5110 !grad          do k=1,3
5111 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5112 !grad          enddo
5113 !grad          kstart=min0(i+1,j)
5114 !grad          kend=max0(i-1,j-1)
5115 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5116 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5117 !grad          do k=kstart,kend
5118 !grad            do l=1,3
5119 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5120 !grad            enddo
5121 !grad          enddo
5122           do k=1,3
5123             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5124             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5125           enddo
5126         enddo
5127
5128         enddo ! iint
5129       enddo ! i
5130       return
5131       end subroutine escp_soft_sphere
5132 !-----------------------------------------------------------------------------
5133       subroutine escp(evdw2,evdw2_14)
5134 !
5135 ! This subroutine calculates the excluded-volume interaction energy between
5136 ! peptide-group centers and side chains and its gradient in virtual-bond and
5137 ! side-chain vectors.
5138 !
5139 !      implicit real*8 (a-h,o-z)
5140 !      include 'DIMENSIONS'
5141 !      include 'COMMON.GEO'
5142 !      include 'COMMON.VAR'
5143 !      include 'COMMON.LOCAL'
5144 !      include 'COMMON.CHAIN'
5145 !      include 'COMMON.DERIV'
5146 !      include 'COMMON.INTERACT'
5147 !      include 'COMMON.FFIELD'
5148 !      include 'COMMON.IOUNITS'
5149 !      include 'COMMON.CONTROL'
5150       real(kind=8),dimension(3) :: ggg
5151 !el local variables
5152       integer :: i,iint,j,k,iteli,itypj,subchap
5153       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
5154                    e1,e2,evdwij,rij
5155       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
5156                     dist_temp, dist_init
5157       integer xshift,yshift,zshift
5158
5159       evdw2=0.0D0
5160       evdw2_14=0.0d0
5161 !d    print '(a)','Enter ESCP'
5162 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5163       do i=iatscp_s,iatscp_e
5164         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
5165         iteli=itel(i)
5166         xi=0.5D0*(c(1,i)+c(1,i+1))
5167         yi=0.5D0*(c(2,i)+c(2,i+1))
5168         zi=0.5D0*(c(3,i)+c(3,i+1))
5169           xi=mod(xi,boxxsize)
5170           if (xi.lt.0) xi=xi+boxxsize
5171           yi=mod(yi,boxysize)
5172           if (yi.lt.0) yi=yi+boxysize
5173           zi=mod(zi,boxzsize)
5174           if (zi.lt.0) zi=zi+boxzsize
5175
5176         do iint=1,nscp_gr(i)
5177
5178         do j=iscpstart(i,iint),iscpend(i,iint)
5179           itypj=iabs(itype(j,1))
5180           if (itypj.eq.ntyp1) cycle
5181 ! Uncomment following three lines for SC-p interactions
5182 !         xj=c(1,nres+j)-xi
5183 !         yj=c(2,nres+j)-yi
5184 !         zj=c(3,nres+j)-zi
5185 ! Uncomment following three lines for Ca-p interactions
5186 !          xj=c(1,j)-xi
5187 !          yj=c(2,j)-yi
5188 !          zj=c(3,j)-zi
5189           xj=c(1,j)
5190           yj=c(2,j)
5191           zj=c(3,j)
5192           xj=mod(xj,boxxsize)
5193           if (xj.lt.0) xj=xj+boxxsize
5194           yj=mod(yj,boxysize)
5195           if (yj.lt.0) yj=yj+boxysize
5196           zj=mod(zj,boxzsize)
5197           if (zj.lt.0) zj=zj+boxzsize
5198       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5199       xj_safe=xj
5200       yj_safe=yj
5201       zj_safe=zj
5202       subchap=0
5203       do xshift=-1,1
5204       do yshift=-1,1
5205       do zshift=-1,1
5206           xj=xj_safe+xshift*boxxsize
5207           yj=yj_safe+yshift*boxysize
5208           zj=zj_safe+zshift*boxzsize
5209           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5210           if(dist_temp.lt.dist_init) then
5211             dist_init=dist_temp
5212             xj_temp=xj
5213             yj_temp=yj
5214             zj_temp=zj
5215             subchap=1
5216           endif
5217        enddo
5218        enddo
5219        enddo
5220        if (subchap.eq.1) then
5221           xj=xj_temp-xi
5222           yj=yj_temp-yi
5223           zj=zj_temp-zi
5224        else
5225           xj=xj_safe-xi
5226           yj=yj_safe-yi
5227           zj=zj_safe-zi
5228        endif
5229
5230           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5231           rij=dsqrt(1.0d0/rrij)
5232             sss_ele_cut=sscale_ele(rij)
5233             sss_ele_grad=sscagrad_ele(rij)
5234 !            print *,sss_ele_cut,sss_ele_grad,&
5235 !            (rij),r_cut_ele,rlamb_ele
5236             if (sss_ele_cut.le.0.0) cycle
5237           fac=rrij**expon2
5238           e1=fac*fac*aad(itypj,iteli)
5239           e2=fac*bad(itypj,iteli)
5240           if (iabs(j-i) .le. 2) then
5241             e1=scal14*e1
5242             e2=scal14*e2
5243             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5244           endif
5245           evdwij=e1+e2
5246           evdw2=evdw2+evdwij*sss_ele_cut
5247 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5248 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5249           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5250              'evdw2',i,j,evdwij
5251 !
5252 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5253 !
5254           fac=-(evdwij+e1)*rrij*sss_ele_cut
5255           fac=fac+evdwij*sss_ele_grad/rij/expon
5256           ggg(1)=xj*fac
5257           ggg(2)=yj*fac
5258           ggg(3)=zj*fac
5259 !grad          if (j.lt.i) then
5260 !d          write (iout,*) 'j<i'
5261 ! Uncomment following three lines for SC-p interactions
5262 !           do k=1,3
5263 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5264 !           enddo
5265 !grad          else
5266 !d          write (iout,*) 'j>i'
5267 !grad            do k=1,3
5268 !grad              ggg(k)=-ggg(k)
5269 ! Uncomment following line for SC-p interactions
5270 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5271 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5272 !grad            enddo
5273 !grad          endif
5274 !grad          do k=1,3
5275 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5276 !grad          enddo
5277 !grad          kstart=min0(i+1,j)
5278 !grad          kend=max0(i-1,j-1)
5279 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5280 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5281 !grad          do k=kstart,kend
5282 !grad            do l=1,3
5283 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5284 !grad            enddo
5285 !grad          enddo
5286           do k=1,3
5287             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5288             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5289           enddo
5290         enddo
5291
5292         enddo ! iint
5293       enddo ! i
5294       do i=1,nct
5295         do j=1,3
5296           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5297           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5298           gradx_scp(j,i)=expon*gradx_scp(j,i)
5299         enddo
5300       enddo
5301 !******************************************************************************
5302 !
5303 !                              N O T E !!!
5304 !
5305 ! To save time the factor EXPON has been extracted from ALL components
5306 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5307 ! use!
5308 !
5309 !******************************************************************************
5310       return
5311       end subroutine escp
5312 !-----------------------------------------------------------------------------
5313       subroutine edis(ehpb)
5314 !
5315 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5316 !
5317 !      implicit real*8 (a-h,o-z)
5318 !      include 'DIMENSIONS'
5319 !      include 'COMMON.SBRIDGE'
5320 !      include 'COMMON.CHAIN'
5321 !      include 'COMMON.DERIV'
5322 !      include 'COMMON.VAR'
5323 !      include 'COMMON.INTERACT'
5324 !      include 'COMMON.IOUNITS'
5325       real(kind=8),dimension(3) :: ggg
5326 !el local variables
5327       integer :: i,j,ii,jj,iii,jjj,k
5328       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5329
5330       ehpb=0.0D0
5331 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5332 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5333       if (link_end.eq.0) return
5334       do i=link_start,link_end
5335 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5336 ! CA-CA distance used in regularization of structure.
5337         ii=ihpb(i)
5338         jj=jhpb(i)
5339 ! iii and jjj point to the residues for which the distance is assigned.
5340         if (ii.gt.nres) then
5341           iii=ii-nres
5342           jjj=jj-nres
5343         else
5344           iii=ii
5345           jjj=jj
5346         endif
5347 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5348 !     &    dhpb(i),dhpb1(i),forcon(i)
5349 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5350 !    distance and angle dependent SS bond potential.
5351 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5352 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5353         if (.not.dyn_ss .and. i.le.nss) then
5354 ! 15/02/13 CC dynamic SSbond - additional check
5355          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5356         iabs(itype(jjj,1)).eq.1) then
5357           call ssbond_ene(iii,jjj,eij)
5358           ehpb=ehpb+2*eij
5359 !d          write (iout,*) "eij",eij
5360          endif
5361         else if (ii.gt.nres .and. jj.gt.nres) then
5362 !c Restraints from contact prediction
5363           dd=dist(ii,jj)
5364           if (constr_dist.eq.11) then
5365             ehpb=ehpb+fordepth(i)**4.0d0 &
5366                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5367             fac=fordepth(i)**4.0d0 &
5368                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5369           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5370             ehpb,fordepth(i),dd
5371            else
5372           if (dhpb1(i).gt.0.0d0) then
5373             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5374             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5375 !c            write (iout,*) "beta nmr",
5376 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5377           else
5378             dd=dist(ii,jj)
5379             rdis=dd-dhpb(i)
5380 !C Get the force constant corresponding to this distance.
5381             waga=forcon(i)
5382 !C Calculate the contribution to energy.
5383             ehpb=ehpb+waga*rdis*rdis
5384 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5385 !C
5386 !C Evaluate gradient.
5387 !C
5388             fac=waga*rdis/dd
5389           endif
5390           endif
5391           do j=1,3
5392             ggg(j)=fac*(c(j,jj)-c(j,ii))
5393           enddo
5394           do j=1,3
5395             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5396             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5397           enddo
5398           do k=1,3
5399             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5400             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5401           enddo
5402         else
5403           dd=dist(ii,jj)
5404           if (constr_dist.eq.11) then
5405             ehpb=ehpb+fordepth(i)**4.0d0 &
5406                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5407             fac=fordepth(i)**4.0d0 &
5408                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5409           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5410          ehpb,fordepth(i),dd
5411            else
5412           if (dhpb1(i).gt.0.0d0) then
5413             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5414             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5415 !c            write (iout,*) "alph nmr",
5416 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5417           else
5418             rdis=dd-dhpb(i)
5419 !C Get the force constant corresponding to this distance.
5420             waga=forcon(i)
5421 !C Calculate the contribution to energy.
5422             ehpb=ehpb+waga*rdis*rdis
5423 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5424 !C
5425 !C Evaluate gradient.
5426 !C
5427             fac=waga*rdis/dd
5428           endif
5429           endif
5430
5431             do j=1,3
5432               ggg(j)=fac*(c(j,jj)-c(j,ii))
5433             enddo
5434 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5435 !C If this is a SC-SC distance, we need to calculate the contributions to the
5436 !C Cartesian gradient in the SC vectors (ghpbx).
5437           if (iii.lt.ii) then
5438           do j=1,3
5439             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5440             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5441           enddo
5442           endif
5443 !cgrad        do j=iii,jjj-1
5444 !cgrad          do k=1,3
5445 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5446 !cgrad          enddo
5447 !cgrad        enddo
5448           do k=1,3
5449             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5450             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5451           enddo
5452         endif
5453       enddo
5454       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5455
5456       return
5457       end subroutine edis
5458 !-----------------------------------------------------------------------------
5459       subroutine ssbond_ene(i,j,eij)
5460 !
5461 ! Calculate the distance and angle dependent SS-bond potential energy
5462 ! using a free-energy function derived based on RHF/6-31G** ab initio
5463 ! calculations of diethyl disulfide.
5464 !
5465 ! A. Liwo and U. Kozlowska, 11/24/03
5466 !
5467 !      implicit real*8 (a-h,o-z)
5468 !      include 'DIMENSIONS'
5469 !      include 'COMMON.SBRIDGE'
5470 !      include 'COMMON.CHAIN'
5471 !      include 'COMMON.DERIV'
5472 !      include 'COMMON.LOCAL'
5473 !      include 'COMMON.INTERACT'
5474 !      include 'COMMON.VAR'
5475 !      include 'COMMON.IOUNITS'
5476       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5477 !el local variables
5478       integer :: i,j,itypi,itypj,k
5479       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5480                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5481                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5482                    cosphi,ggk
5483
5484       itypi=iabs(itype(i,1))
5485       xi=c(1,nres+i)
5486       yi=c(2,nres+i)
5487       zi=c(3,nres+i)
5488       dxi=dc_norm(1,nres+i)
5489       dyi=dc_norm(2,nres+i)
5490       dzi=dc_norm(3,nres+i)
5491 !      dsci_inv=dsc_inv(itypi)
5492       dsci_inv=vbld_inv(nres+i)
5493       itypj=iabs(itype(j,1))
5494 !      dscj_inv=dsc_inv(itypj)
5495       dscj_inv=vbld_inv(nres+j)
5496       xj=c(1,nres+j)-xi
5497       yj=c(2,nres+j)-yi
5498       zj=c(3,nres+j)-zi
5499       dxj=dc_norm(1,nres+j)
5500       dyj=dc_norm(2,nres+j)
5501       dzj=dc_norm(3,nres+j)
5502       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5503       rij=dsqrt(rrij)
5504       erij(1)=xj*rij
5505       erij(2)=yj*rij
5506       erij(3)=zj*rij
5507       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5508       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5509       om12=dxi*dxj+dyi*dyj+dzi*dzj
5510       do k=1,3
5511         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5512         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5513       enddo
5514       rij=1.0d0/rij
5515       deltad=rij-d0cm
5516       deltat1=1.0d0-om1
5517       deltat2=1.0d0+om2
5518       deltat12=om2-om1+2.0d0
5519       cosphi=om12-om1*om2
5520       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5521         +akct*deltad*deltat12 &
5522         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5523 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5524 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5525 !     &  " deltat12",deltat12," eij",eij
5526       ed=2*akcm*deltad+akct*deltat12
5527       pom1=akct*deltad
5528       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5529       eom1=-2*akth*deltat1-pom1-om2*pom2
5530       eom2= 2*akth*deltat2+pom1-om1*pom2
5531       eom12=pom2
5532       do k=1,3
5533         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5534         ghpbx(k,i)=ghpbx(k,i)-ggk &
5535                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5536                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5537         ghpbx(k,j)=ghpbx(k,j)+ggk &
5538                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5539                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5540         ghpbc(k,i)=ghpbc(k,i)-ggk
5541         ghpbc(k,j)=ghpbc(k,j)+ggk
5542       enddo
5543 !
5544 ! Calculate the components of the gradient in DC and X
5545 !
5546 !grad      do k=i,j-1
5547 !grad        do l=1,3
5548 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5549 !grad        enddo
5550 !grad      enddo
5551       return
5552       end subroutine ssbond_ene
5553 !-----------------------------------------------------------------------------
5554       subroutine ebond(estr)
5555 !
5556 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5557 !
5558 !      implicit real*8 (a-h,o-z)
5559 !      include 'DIMENSIONS'
5560 !      include 'COMMON.LOCAL'
5561 !      include 'COMMON.GEO'
5562 !      include 'COMMON.INTERACT'
5563 !      include 'COMMON.DERIV'
5564 !      include 'COMMON.VAR'
5565 !      include 'COMMON.CHAIN'
5566 !      include 'COMMON.IOUNITS'
5567 !      include 'COMMON.NAMES'
5568 !      include 'COMMON.FFIELD'
5569 !      include 'COMMON.CONTROL'
5570 !      include 'COMMON.SETUP'
5571       real(kind=8),dimension(3) :: u,ud
5572 !el local variables
5573       integer :: i,j,iti,nbi,k
5574       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5575                    uprod1,uprod2
5576
5577       estr=0.0d0
5578       estr1=0.0d0
5579 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5580 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5581
5582       do i=ibondp_start,ibondp_end
5583         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5584         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5585 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5586 !C          do j=1,3
5587 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5588 !C            *dc(j,i-1)/vbld(i)
5589 !C          enddo
5590 !C          if (energy_dec) write(iout,*) &
5591 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5592         diff = vbld(i)-vbldpDUM
5593         else
5594         diff = vbld(i)-vbldp0
5595         endif
5596         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5597            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5598         estr=estr+diff*diff
5599         do j=1,3
5600           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5601         enddo
5602 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5603 !        endif
5604       enddo
5605       estr=0.5d0*AKP*estr+estr1
5606 !      print *,"estr_bb",estr,AKP
5607 !
5608 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5609 !
5610       do i=ibond_start,ibond_end
5611         iti=iabs(itype(i,1))
5612         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5613         if (iti.ne.10 .and. iti.ne.ntyp1) then
5614           nbi=nbondterm(iti)
5615           if (nbi.eq.1) then
5616             diff=vbld(i+nres)-vbldsc0(1,iti)
5617             if (energy_dec) write (iout,*) &
5618             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5619             AKSC(1,iti),AKSC(1,iti)*diff*diff
5620             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5621 !            print *,"estr_sc",estr
5622             do j=1,3
5623               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5624             enddo
5625           else
5626             do j=1,nbi
5627               diff=vbld(i+nres)-vbldsc0(j,iti)
5628               ud(j)=aksc(j,iti)*diff
5629               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5630             enddo
5631             uprod=u(1)
5632             do j=2,nbi
5633               uprod=uprod*u(j)
5634             enddo
5635             usum=0.0d0
5636             usumsqder=0.0d0
5637             do j=1,nbi
5638               uprod1=1.0d0
5639               uprod2=1.0d0
5640               do k=1,nbi
5641                 if (k.ne.j) then
5642                   uprod1=uprod1*u(k)
5643                   uprod2=uprod2*u(k)*u(k)
5644                 endif
5645               enddo
5646               usum=usum+uprod1
5647               usumsqder=usumsqder+ud(j)*uprod2
5648             enddo
5649             estr=estr+uprod/usum
5650 !            print *,"estr_sc",estr,i
5651
5652              if (energy_dec) write (iout,*) &
5653             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5654             AKSC(1,iti),uprod/usum
5655             do j=1,3
5656              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5657             enddo
5658           endif
5659         endif
5660       enddo
5661       return
5662       end subroutine ebond
5663 #ifdef CRYST_THETA
5664 !-----------------------------------------------------------------------------
5665       subroutine ebend(etheta)
5666 !
5667 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5668 ! angles gamma and its derivatives in consecutive thetas and gammas.
5669 !
5670       use comm_calcthet
5671 !      implicit real*8 (a-h,o-z)
5672 !      include 'DIMENSIONS'
5673 !      include 'COMMON.LOCAL'
5674 !      include 'COMMON.GEO'
5675 !      include 'COMMON.INTERACT'
5676 !      include 'COMMON.DERIV'
5677 !      include 'COMMON.VAR'
5678 !      include 'COMMON.CHAIN'
5679 !      include 'COMMON.IOUNITS'
5680 !      include 'COMMON.NAMES'
5681 !      include 'COMMON.FFIELD'
5682 !      include 'COMMON.CONTROL'
5683 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5684 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5685 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5686 !el      integer :: it
5687 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5688 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5689 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5690 !el local variables
5691       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5692        ichir21,ichir22
5693       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5694        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5695        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5696       real(kind=8),dimension(2) :: y,z
5697
5698       delta=0.02d0*pi
5699 !      time11=dexp(-2*time)
5700 !      time12=1.0d0
5701       etheta=0.0D0
5702 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5703       do i=ithet_start,ithet_end
5704         if (itype(i-1,1).eq.ntyp1) cycle
5705 ! Zero the energy function and its derivative at 0 or pi.
5706         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5707         it=itype(i-1,1)
5708         ichir1=isign(1,itype(i-2,1))
5709         ichir2=isign(1,itype(i,1))
5710          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5711          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5712          if (itype(i-1,1).eq.10) then
5713           itype1=isign(10,itype(i-2,1))
5714           ichir11=isign(1,itype(i-2,1))
5715           ichir12=isign(1,itype(i-2,1))
5716           itype2=isign(10,itype(i,1))
5717           ichir21=isign(1,itype(i,1))
5718           ichir22=isign(1,itype(i,1))
5719          endif
5720
5721         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5722 #ifdef OSF
5723           phii=phi(i)
5724           if (phii.ne.phii) phii=150.0
5725 #else
5726           phii=phi(i)
5727 #endif
5728           y(1)=dcos(phii)
5729           y(2)=dsin(phii)
5730         else
5731           y(1)=0.0D0
5732           y(2)=0.0D0
5733         endif
5734         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5735 #ifdef OSF
5736           phii1=phi(i+1)
5737           if (phii1.ne.phii1) phii1=150.0
5738           phii1=pinorm(phii1)
5739           z(1)=cos(phii1)
5740 #else
5741           phii1=phi(i+1)
5742           z(1)=dcos(phii1)
5743 #endif
5744           z(2)=dsin(phii1)
5745         else
5746           z(1)=0.0D0
5747           z(2)=0.0D0
5748         endif
5749 ! Calculate the "mean" value of theta from the part of the distribution
5750 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5751 ! In following comments this theta will be referred to as t_c.
5752         thet_pred_mean=0.0d0
5753         do k=1,2
5754             athetk=athet(k,it,ichir1,ichir2)
5755             bthetk=bthet(k,it,ichir1,ichir2)
5756           if (it.eq.10) then
5757              athetk=athet(k,itype1,ichir11,ichir12)
5758              bthetk=bthet(k,itype2,ichir21,ichir22)
5759           endif
5760          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5761         enddo
5762         dthett=thet_pred_mean*ssd
5763         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5764 ! Derivatives of the "mean" values in gamma1 and gamma2.
5765         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5766                +athet(2,it,ichir1,ichir2)*y(1))*ss
5767         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5768                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5769          if (it.eq.10) then
5770         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5771              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5772         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5773                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5774          endif
5775         if (theta(i).gt.pi-delta) then
5776           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5777                E_tc0)
5778           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5779           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5780           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5781               E_theta)
5782           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5783               E_tc)
5784         else if (theta(i).lt.delta) then
5785           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5786           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5787           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5788               E_theta)
5789           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5790           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5791               E_tc)
5792         else
5793           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5794               E_theta,E_tc)
5795         endif
5796         etheta=etheta+ethetai
5797         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5798             'ebend',i,ethetai
5799         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5800         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5801         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5802       enddo
5803 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5804
5805 ! Ufff.... We've done all this!!!
5806       return
5807       end subroutine ebend
5808 !-----------------------------------------------------------------------------
5809       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5810
5811       use comm_calcthet
5812 !      implicit real*8 (a-h,o-z)
5813 !      include 'DIMENSIONS'
5814 !      include 'COMMON.LOCAL'
5815 !      include 'COMMON.IOUNITS'
5816 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5817 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5818 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5819       integer :: i,j,k
5820       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5821 !el      integer :: it
5822 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5823 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5824 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5825 !el local variables
5826       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5827        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5828
5829 ! Calculate the contributions to both Gaussian lobes.
5830 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5831 ! The "polynomial part" of the "standard deviation" of this part of
5832 ! the distribution.
5833         sig=polthet(3,it)
5834         do j=2,0,-1
5835           sig=sig*thet_pred_mean+polthet(j,it)
5836         enddo
5837 ! Derivative of the "interior part" of the "standard deviation of the"
5838 ! gamma-dependent Gaussian lobe in t_c.
5839         sigtc=3*polthet(3,it)
5840         do j=2,1,-1
5841           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5842         enddo
5843         sigtc=sig*sigtc
5844 ! Set the parameters of both Gaussian lobes of the distribution.
5845 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5846         fac=sig*sig+sigc0(it)
5847         sigcsq=fac+fac
5848         sigc=1.0D0/sigcsq
5849 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5850         sigsqtc=-4.0D0*sigcsq*sigtc
5851 !       print *,i,sig,sigtc,sigsqtc
5852 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5853         sigtc=-sigtc/(fac*fac)
5854 ! Following variable is sigma(t_c)**(-2)
5855         sigcsq=sigcsq*sigcsq
5856         sig0i=sig0(it)
5857         sig0inv=1.0D0/sig0i**2
5858         delthec=thetai-thet_pred_mean
5859         delthe0=thetai-theta0i
5860         term1=-0.5D0*sigcsq*delthec*delthec
5861         term2=-0.5D0*sig0inv*delthe0*delthe0
5862 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5863 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5864 ! to the energy (this being the log of the distribution) at the end of energy
5865 ! term evaluation for this virtual-bond angle.
5866         if (term1.gt.term2) then
5867           termm=term1
5868           term2=dexp(term2-termm)
5869           term1=1.0d0
5870         else
5871           termm=term2
5872           term1=dexp(term1-termm)
5873           term2=1.0d0
5874         endif
5875 ! The ratio between the gamma-independent and gamma-dependent lobes of
5876 ! the distribution is a Gaussian function of thet_pred_mean too.
5877         diffak=gthet(2,it)-thet_pred_mean
5878         ratak=diffak/gthet(3,it)**2
5879         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5880 ! Let's differentiate it in thet_pred_mean NOW.
5881         aktc=ak*ratak
5882 ! Now put together the distribution terms to make complete distribution.
5883         termexp=term1+ak*term2
5884         termpre=sigc+ak*sig0i
5885 ! Contribution of the bending energy from this theta is just the -log of
5886 ! the sum of the contributions from the two lobes and the pre-exponential
5887 ! factor. Simple enough, isn't it?
5888         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5889 ! NOW the derivatives!!!
5890 ! 6/6/97 Take into account the deformation.
5891         E_theta=(delthec*sigcsq*term1 &
5892              +ak*delthe0*sig0inv*term2)/termexp
5893         E_tc=((sigtc+aktc*sig0i)/termpre &
5894             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5895              aktc*term2)/termexp)
5896       return
5897       end subroutine theteng
5898 #else
5899 !-----------------------------------------------------------------------------
5900       subroutine ebend(etheta,ethetacnstr)
5901 !
5902 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5903 ! angles gamma and its derivatives in consecutive thetas and gammas.
5904 ! ab initio-derived potentials from
5905 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5906 !
5907 !      implicit real*8 (a-h,o-z)
5908 !      include 'DIMENSIONS'
5909 !      include 'COMMON.LOCAL'
5910 !      include 'COMMON.GEO'
5911 !      include 'COMMON.INTERACT'
5912 !      include 'COMMON.DERIV'
5913 !      include 'COMMON.VAR'
5914 !      include 'COMMON.CHAIN'
5915 !      include 'COMMON.IOUNITS'
5916 !      include 'COMMON.NAMES'
5917 !      include 'COMMON.FFIELD'
5918 !      include 'COMMON.CONTROL'
5919       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5920       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5921       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5922       logical :: lprn=.false., lprn1=.false.
5923 !el local variables
5924       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5925       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5926       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
5927 ! local variables for constrains
5928       real(kind=8) :: difi,thetiii
5929        integer itheta
5930 !      write(iout,*) "in ebend",ithet_start,ithet_end
5931       call flush(iout)
5932       etheta=0.0D0
5933       do i=ithet_start,ithet_end
5934         if (itype(i-1,1).eq.ntyp1) cycle
5935         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
5936         if (iabs(itype(i+1,1)).eq.20) iblock=2
5937         if (iabs(itype(i+1,1)).ne.20) iblock=1
5938         dethetai=0.0d0
5939         dephii=0.0d0
5940         dephii1=0.0d0
5941         theti2=0.5d0*theta(i)
5942         ityp2=ithetyp((itype(i-1,1)))
5943         do k=1,nntheterm
5944           coskt(k)=dcos(k*theti2)
5945           sinkt(k)=dsin(k*theti2)
5946         enddo
5947         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
5948 #ifdef OSF
5949           phii=phi(i)
5950           if (phii.ne.phii) phii=150.0
5951 #else
5952           phii=phi(i)
5953 #endif
5954           ityp1=ithetyp((itype(i-2,1)))
5955 ! propagation of chirality for glycine type
5956           do k=1,nsingle
5957             cosph1(k)=dcos(k*phii)
5958             sinph1(k)=dsin(k*phii)
5959           enddo
5960         else
5961           phii=0.0d0
5962           ityp1=ithetyp(itype(i-2,1))
5963           do k=1,nsingle
5964             cosph1(k)=0.0d0
5965             sinph1(k)=0.0d0
5966           enddo
5967         endif
5968         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
5969 #ifdef OSF
5970           phii1=phi(i+1)
5971           if (phii1.ne.phii1) phii1=150.0
5972           phii1=pinorm(phii1)
5973 #else
5974           phii1=phi(i+1)
5975 #endif
5976           ityp3=ithetyp((itype(i,1)))
5977           do k=1,nsingle
5978             cosph2(k)=dcos(k*phii1)
5979             sinph2(k)=dsin(k*phii1)
5980           enddo
5981         else
5982           phii1=0.0d0
5983           ityp3=ithetyp(itype(i,1))
5984           do k=1,nsingle
5985             cosph2(k)=0.0d0
5986             sinph2(k)=0.0d0
5987           enddo
5988         endif
5989         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5990         do k=1,ndouble
5991           do l=1,k-1
5992             ccl=cosph1(l)*cosph2(k-l)
5993             ssl=sinph1(l)*sinph2(k-l)
5994             scl=sinph1(l)*cosph2(k-l)
5995             csl=cosph1(l)*sinph2(k-l)
5996             cosph1ph2(l,k)=ccl-ssl
5997             cosph1ph2(k,l)=ccl+ssl
5998             sinph1ph2(l,k)=scl+csl
5999             sinph1ph2(k,l)=scl-csl
6000           enddo
6001         enddo
6002         if (lprn) then
6003         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
6004           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6005         write (iout,*) "coskt and sinkt"
6006         do k=1,nntheterm
6007           write (iout,*) k,coskt(k),sinkt(k)
6008         enddo
6009         endif
6010         do k=1,ntheterm
6011           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6012           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
6013             *coskt(k)
6014           if (lprn) &
6015           write (iout,*) "k",k,&
6016            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
6017            " ethetai",ethetai
6018         enddo
6019         if (lprn) then
6020         write (iout,*) "cosph and sinph"
6021         do k=1,nsingle
6022           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6023         enddo
6024         write (iout,*) "cosph1ph2 and sinph2ph2"
6025         do k=2,ndouble
6026           do l=1,k-1
6027             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
6028                sinph1ph2(l,k),sinph1ph2(k,l)
6029           enddo
6030         enddo
6031         write(iout,*) "ethetai",ethetai
6032         endif
6033         do m=1,ntheterm2
6034           do k=1,nsingle
6035             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
6036                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
6037                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
6038                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6039             ethetai=ethetai+sinkt(m)*aux
6040             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6041             dephii=dephii+k*sinkt(m)* &
6042                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
6043                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6044             dephii1=dephii1+k*sinkt(m)* &
6045                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
6046                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6047             if (lprn) &
6048             write (iout,*) "m",m," k",k," bbthet", &
6049                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
6050                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
6051                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
6052                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6053           enddo
6054         enddo
6055         if (lprn) &
6056         write(iout,*) "ethetai",ethetai
6057         do m=1,ntheterm3
6058           do k=2,ndouble
6059             do l=1,k-1
6060               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6061                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
6062                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6063                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6064               ethetai=ethetai+sinkt(m)*aux
6065               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6066               dephii=dephii+l*sinkt(m)* &
6067                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
6068                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6069                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
6070                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6071               dephii1=dephii1+(k-l)*sinkt(m)* &
6072                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
6073                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
6074                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
6075                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6076               if (lprn) then
6077               write (iout,*) "m",m," k",k," l",l," ffthet",&
6078                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6079                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
6080                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
6081                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
6082                   " ethetai",ethetai
6083               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
6084                   cosph1ph2(k,l)*sinkt(m),&
6085                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6086               endif
6087             enddo
6088           enddo
6089         enddo
6090 10      continue
6091 !        lprn1=.true.
6092         if (lprn1) &
6093           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
6094          i,theta(i)*rad2deg,phii*rad2deg,&
6095          phii1*rad2deg,ethetai
6096 !        lprn1=.false.
6097         etheta=etheta+ethetai
6098         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6099                                     'ebend',i,ethetai
6100         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6101         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6102         gloc(nphi+i-2,icg)=wang*dethetai
6103       enddo
6104 !-----------thete constrains
6105 !      if (tor_mode.ne.2) then
6106       ethetacnstr=0.0d0
6107       print *,ithetaconstr_start,ithetaconstr_end,"TU"
6108       do i=ithetaconstr_start,ithetaconstr_end
6109         itheta=itheta_constr(i)
6110         thetiii=theta(itheta)
6111         difi=pinorm(thetiii-theta_constr0(i))
6112         if (difi.gt.theta_drange(i)) then
6113           difi=difi-theta_drange(i)
6114           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6115           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
6116          +for_thet_constr(i)*difi**3
6117         else if (difi.lt.-drange(i)) then
6118           difi=difi+drange(i)
6119           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6120           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
6121          +for_thet_constr(i)*difi**3
6122         else
6123           difi=0.0
6124         endif
6125        if (energy_dec) then
6126         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", &
6127          i,itheta,rad2deg*thetiii, &
6128          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i), &
6129          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, &
6130          gloc(itheta+nphi-2,icg)
6131         endif
6132       enddo
6133 !      endif
6134
6135       return
6136       end subroutine ebend
6137 #endif
6138 #ifdef CRYST_SC
6139 !-----------------------------------------------------------------------------
6140       subroutine esc(escloc)
6141 ! Calculate the local energy of a side chain and its derivatives in the
6142 ! corresponding virtual-bond valence angles THETA and the spherical angles
6143 ! ALPHA and OMEGA.
6144 !
6145       use comm_sccalc
6146 !      implicit real*8 (a-h,o-z)
6147 !      include 'DIMENSIONS'
6148 !      include 'COMMON.GEO'
6149 !      include 'COMMON.LOCAL'
6150 !      include 'COMMON.VAR'
6151 !      include 'COMMON.INTERACT'
6152 !      include 'COMMON.DERIV'
6153 !      include 'COMMON.CHAIN'
6154 !      include 'COMMON.IOUNITS'
6155 !      include 'COMMON.NAMES'
6156 !      include 'COMMON.FFIELD'
6157 !      include 'COMMON.CONTROL'
6158       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
6159          ddersc0,ddummy,xtemp,temp
6160 !el      real(kind=8) :: time11,time12,time112,theti
6161       real(kind=8) :: escloc,delta
6162 !el      integer :: it,nlobit
6163 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6164 !el local variables
6165       integer :: i,k
6166       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
6167        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
6168       delta=0.02d0*pi
6169       escloc=0.0D0
6170 !     write (iout,'(a)') 'ESC'
6171       do i=loc_start,loc_end
6172         it=itype(i,1)
6173         if (it.eq.ntyp1) cycle
6174         if (it.eq.10) goto 1
6175         nlobit=nlob(iabs(it))
6176 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
6177 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6178         theti=theta(i+1)-pipol
6179         x(1)=dtan(theti)
6180         x(2)=alph(i)
6181         x(3)=omeg(i)
6182
6183         if (x(2).gt.pi-delta) then
6184           xtemp(1)=x(1)
6185           xtemp(2)=pi-delta
6186           xtemp(3)=x(3)
6187           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6188           xtemp(2)=pi
6189           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6190           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
6191               escloci,dersc(2))
6192           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6193               ddersc0(1),dersc(1))
6194           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
6195               ddersc0(3),dersc(3))
6196           xtemp(2)=pi-delta
6197           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6198           xtemp(2)=pi
6199           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6200           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6201                   dersc0(2),esclocbi,dersc02)
6202           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6203                   dersc12,dersc01)
6204           call splinthet(x(2),0.5d0*delta,ss,ssd)
6205           dersc0(1)=dersc01
6206           dersc0(2)=dersc02
6207           dersc0(3)=0.0d0
6208           do k=1,3
6209             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6210           enddo
6211           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6212 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6213 !    &             esclocbi,ss,ssd
6214           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6215 !         escloci=esclocbi
6216 !         write (iout,*) escloci
6217         else if (x(2).lt.delta) then
6218           xtemp(1)=x(1)
6219           xtemp(2)=delta
6220           xtemp(3)=x(3)
6221           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6222           xtemp(2)=0.0d0
6223           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6224           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6225               escloci,dersc(2))
6226           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6227               ddersc0(1),dersc(1))
6228           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6229               ddersc0(3),dersc(3))
6230           xtemp(2)=delta
6231           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6232           xtemp(2)=0.0d0
6233           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6234           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6235                   dersc0(2),esclocbi,dersc02)
6236           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6237                   dersc12,dersc01)
6238           dersc0(1)=dersc01
6239           dersc0(2)=dersc02
6240           dersc0(3)=0.0d0
6241           call splinthet(x(2),0.5d0*delta,ss,ssd)
6242           do k=1,3
6243             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6244           enddo
6245           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6246 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6247 !    &             esclocbi,ss,ssd
6248           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6249 !         write (iout,*) escloci
6250         else
6251           call enesc(x,escloci,dersc,ddummy,.false.)
6252         endif
6253
6254         escloc=escloc+escloci
6255         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6256            'escloc',i,escloci
6257 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6258
6259         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6260          wscloc*dersc(1)
6261         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6262         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6263     1   continue
6264       enddo
6265       return
6266       end subroutine esc
6267 !-----------------------------------------------------------------------------
6268       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6269
6270       use comm_sccalc
6271 !      implicit real*8 (a-h,o-z)
6272 !      include 'DIMENSIONS'
6273 !      include 'COMMON.GEO'
6274 !      include 'COMMON.LOCAL'
6275 !      include 'COMMON.IOUNITS'
6276 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6277       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6278       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6279       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6280       real(kind=8) :: escloci
6281       logical :: mixed
6282 !el local variables
6283       integer :: j,iii,l,k !el,it,nlobit
6284       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6285 !el       time11,time12,time112
6286 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6287         escloc_i=0.0D0
6288         do j=1,3
6289           dersc(j)=0.0D0
6290           if (mixed) ddersc(j)=0.0d0
6291         enddo
6292         x3=x(3)
6293
6294 ! Because of periodicity of the dependence of the SC energy in omega we have
6295 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6296 ! To avoid underflows, first compute & store the exponents.
6297
6298         do iii=-1,1
6299
6300           x(3)=x3+iii*dwapi
6301
6302           do j=1,nlobit
6303             do k=1,3
6304               z(k)=x(k)-censc(k,j,it)
6305             enddo
6306             do k=1,3
6307               Axk=0.0D0
6308               do l=1,3
6309                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6310               enddo
6311               Ax(k,j,iii)=Axk
6312             enddo
6313             expfac=0.0D0
6314             do k=1,3
6315               expfac=expfac+Ax(k,j,iii)*z(k)
6316             enddo
6317             contr(j,iii)=expfac
6318           enddo ! j
6319
6320         enddo ! iii
6321
6322         x(3)=x3
6323 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6324 ! subsequent NaNs and INFs in energy calculation.
6325 ! Find the largest exponent
6326         emin=contr(1,-1)
6327         do iii=-1,1
6328           do j=1,nlobit
6329             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6330           enddo
6331         enddo
6332         emin=0.5D0*emin
6333 !d      print *,'it=',it,' emin=',emin
6334
6335 ! Compute the contribution to SC energy and derivatives
6336         do iii=-1,1
6337
6338           do j=1,nlobit
6339 #ifdef OSF
6340             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6341             if(adexp.ne.adexp) adexp=1.0
6342             expfac=dexp(adexp)
6343 #else
6344             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6345 #endif
6346 !d          print *,'j=',j,' expfac=',expfac
6347             escloc_i=escloc_i+expfac
6348             do k=1,3
6349               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6350             enddo
6351             if (mixed) then
6352               do k=1,3,2
6353                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6354                   +gaussc(k,2,j,it))*expfac
6355               enddo
6356             endif
6357           enddo
6358
6359         enddo ! iii
6360
6361         dersc(1)=dersc(1)/cos(theti)**2
6362         ddersc(1)=ddersc(1)/cos(theti)**2
6363         ddersc(3)=ddersc(3)
6364
6365         escloci=-(dlog(escloc_i)-emin)
6366         do j=1,3
6367           dersc(j)=dersc(j)/escloc_i
6368         enddo
6369         if (mixed) then
6370           do j=1,3,2
6371             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6372           enddo
6373         endif
6374       return
6375       end subroutine enesc
6376 !-----------------------------------------------------------------------------
6377       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6378
6379       use comm_sccalc
6380 !      implicit real*8 (a-h,o-z)
6381 !      include 'DIMENSIONS'
6382 !      include 'COMMON.GEO'
6383 !      include 'COMMON.LOCAL'
6384 !      include 'COMMON.IOUNITS'
6385 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6386       real(kind=8),dimension(3) :: x,z,dersc
6387       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6388       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6389       real(kind=8) :: escloci,dersc12,emin
6390       logical :: mixed
6391 !el local varables
6392       integer :: j,k,l !el,it,nlobit
6393       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6394
6395       escloc_i=0.0D0
6396
6397       do j=1,3
6398         dersc(j)=0.0D0
6399       enddo
6400
6401       do j=1,nlobit
6402         do k=1,2
6403           z(k)=x(k)-censc(k,j,it)
6404         enddo
6405         z(3)=dwapi
6406         do k=1,3
6407           Axk=0.0D0
6408           do l=1,3
6409             Axk=Axk+gaussc(l,k,j,it)*z(l)
6410           enddo
6411           Ax(k,j)=Axk
6412         enddo
6413         expfac=0.0D0
6414         do k=1,3
6415           expfac=expfac+Ax(k,j)*z(k)
6416         enddo
6417         contr(j)=expfac
6418       enddo ! j
6419
6420 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6421 ! subsequent NaNs and INFs in energy calculation.
6422 ! Find the largest exponent
6423       emin=contr(1)
6424       do j=1,nlobit
6425         if (emin.gt.contr(j)) emin=contr(j)
6426       enddo
6427       emin=0.5D0*emin
6428
6429 ! Compute the contribution to SC energy and derivatives
6430
6431       dersc12=0.0d0
6432       do j=1,nlobit
6433         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6434         escloc_i=escloc_i+expfac
6435         do k=1,2
6436           dersc(k)=dersc(k)+Ax(k,j)*expfac
6437         enddo
6438         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6439                   +gaussc(1,2,j,it))*expfac
6440         dersc(3)=0.0d0
6441       enddo
6442
6443       dersc(1)=dersc(1)/cos(theti)**2
6444       dersc12=dersc12/cos(theti)**2
6445       escloci=-(dlog(escloc_i)-emin)
6446       do j=1,2
6447         dersc(j)=dersc(j)/escloc_i
6448       enddo
6449       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6450       return
6451       end subroutine enesc_bound
6452 #else
6453 !-----------------------------------------------------------------------------
6454       subroutine esc(escloc)
6455 ! Calculate the local energy of a side chain and its derivatives in the
6456 ! corresponding virtual-bond valence angles THETA and the spherical angles
6457 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6458 ! added by Urszula Kozlowska. 07/11/2007
6459 !
6460       use comm_sccalc
6461 !      implicit real*8 (a-h,o-z)
6462 !      include 'DIMENSIONS'
6463 !      include 'COMMON.GEO'
6464 !      include 'COMMON.LOCAL'
6465 !      include 'COMMON.VAR'
6466 !      include 'COMMON.SCROT'
6467 !      include 'COMMON.INTERACT'
6468 !      include 'COMMON.DERIV'
6469 !      include 'COMMON.CHAIN'
6470 !      include 'COMMON.IOUNITS'
6471 !      include 'COMMON.NAMES'
6472 !      include 'COMMON.FFIELD'
6473 !      include 'COMMON.CONTROL'
6474 !      include 'COMMON.VECTORS'
6475       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6476       real(kind=8),dimension(65) :: x
6477       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6478          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6479       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6480       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6481          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6482 !el local variables
6483       integer :: i,j,k !el,it,nlobit
6484       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6485 !el      real(kind=8) :: time11,time12,time112,theti
6486 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6487       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6488                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6489                    sumene1x,sumene2x,sumene3x,sumene4x,&
6490                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6491                    cosfac2xx,sinfac2yy
6492 #ifdef DEBUG
6493       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6494                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6495                    de_dt_num
6496 #endif
6497 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6498
6499       delta=0.02d0*pi
6500       escloc=0.0D0
6501       do i=loc_start,loc_end
6502         if (itype(i,1).eq.ntyp1) cycle
6503         costtab(i+1) =dcos(theta(i+1))
6504         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6505         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6506         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6507         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6508         cosfac=dsqrt(cosfac2)
6509         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6510         sinfac=dsqrt(sinfac2)
6511         it=iabs(itype(i,1))
6512         if (it.eq.10) goto 1
6513 !
6514 !  Compute the axes of tghe local cartesian coordinates system; store in
6515 !   x_prime, y_prime and z_prime
6516 !
6517         do j=1,3
6518           x_prime(j) = 0.00
6519           y_prime(j) = 0.00
6520           z_prime(j) = 0.00
6521         enddo
6522 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6523 !     &   dc_norm(3,i+nres)
6524         do j = 1,3
6525           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6526           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6527         enddo
6528         do j = 1,3
6529           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6530         enddo
6531 !       write (2,*) "i",i
6532 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6533 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6534 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6535 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6536 !      & " xy",scalar(x_prime(1),y_prime(1)),
6537 !      & " xz",scalar(x_prime(1),z_prime(1)),
6538 !      & " yy",scalar(y_prime(1),y_prime(1)),
6539 !      & " yz",scalar(y_prime(1),z_prime(1)),
6540 !      & " zz",scalar(z_prime(1),z_prime(1))
6541 !
6542 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6543 ! to local coordinate system. Store in xx, yy, zz.
6544 !
6545         xx=0.0d0
6546         yy=0.0d0
6547         zz=0.0d0
6548         do j = 1,3
6549           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6550           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6551           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6552         enddo
6553
6554         xxtab(i)=xx
6555         yytab(i)=yy
6556         zztab(i)=zz
6557 !
6558 ! Compute the energy of the ith side cbain
6559 !
6560 !        write (2,*) "xx",xx," yy",yy," zz",zz
6561         it=iabs(itype(i,1))
6562         do j = 1,65
6563           x(j) = sc_parmin(j,it)
6564         enddo
6565 #ifdef CHECK_COORD
6566 !c diagnostics - remove later
6567         xx1 = dcos(alph(2))
6568         yy1 = dsin(alph(2))*dcos(omeg(2))
6569         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6570         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6571           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6572           xx1,yy1,zz1
6573 !,"  --- ", xx_w,yy_w,zz_w
6574 ! end diagnostics
6575 #endif
6576         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6577          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6578          + x(10)*yy*zz
6579         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6580          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6581          + x(20)*yy*zz
6582         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6583          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6584          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6585          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6586          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6587          +x(40)*xx*yy*zz
6588         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6589          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6590          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6591          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6592          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6593          +x(60)*xx*yy*zz
6594         dsc_i   = 0.743d0+x(61)
6595         dp2_i   = 1.9d0+x(62)
6596         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6597                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6598         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6599                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6600         s1=(1+x(63))/(0.1d0 + dscp1)
6601         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6602         s2=(1+x(65))/(0.1d0 + dscp2)
6603         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6604         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6605       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6606 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6607 !     &   sumene4,
6608 !     &   dscp1,dscp2,sumene
6609 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6610         escloc = escloc + sumene
6611 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6612 !     & ,zz,xx,yy
6613 !#define DEBUG
6614 #ifdef DEBUG
6615 !
6616 ! This section to check the numerical derivatives of the energy of ith side
6617 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6618 ! #define DEBUG in the code to turn it on.
6619 !
6620         write (2,*) "sumene               =",sumene
6621         aincr=1.0d-7
6622         xxsave=xx
6623         xx=xx+aincr
6624         write (2,*) xx,yy,zz
6625         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6626         de_dxx_num=(sumenep-sumene)/aincr
6627         xx=xxsave
6628         write (2,*) "xx+ sumene from enesc=",sumenep
6629         yysave=yy
6630         yy=yy+aincr
6631         write (2,*) xx,yy,zz
6632         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6633         de_dyy_num=(sumenep-sumene)/aincr
6634         yy=yysave
6635         write (2,*) "yy+ sumene from enesc=",sumenep
6636         zzsave=zz
6637         zz=zz+aincr
6638         write (2,*) xx,yy,zz
6639         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6640         de_dzz_num=(sumenep-sumene)/aincr
6641         zz=zzsave
6642         write (2,*) "zz+ sumene from enesc=",sumenep
6643         costsave=cost2tab(i+1)
6644         sintsave=sint2tab(i+1)
6645         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6646         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6647         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6648         de_dt_num=(sumenep-sumene)/aincr
6649         write (2,*) " t+ sumene from enesc=",sumenep
6650         cost2tab(i+1)=costsave
6651         sint2tab(i+1)=sintsave
6652 ! End of diagnostics section.
6653 #endif
6654 !
6655 ! Compute the gradient of esc
6656 !
6657 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6658         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6659         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6660         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6661         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6662         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6663         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6664         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6665         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6666         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6667            *(pom_s1/dscp1+pom_s16*dscp1**4)
6668         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6669            *(pom_s2/dscp2+pom_s26*dscp2**4)
6670         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6671         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6672         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6673         +x(40)*yy*zz
6674         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6675         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6676         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6677         +x(60)*yy*zz
6678         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6679               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6680               +(pom1+pom2)*pom_dx
6681 #ifdef DEBUG
6682         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6683 #endif
6684 !
6685         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6686         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6687         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6688         +x(40)*xx*zz
6689         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6690         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6691         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6692         +x(59)*zz**2 +x(60)*xx*zz
6693         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6694               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6695               +(pom1-pom2)*pom_dy
6696 #ifdef DEBUG
6697         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6698 #endif
6699 !
6700         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6701         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6702         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6703         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6704         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6705         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6706         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6707         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6708 #ifdef DEBUG
6709         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6710 #endif
6711 !
6712         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6713         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6714         +pom1*pom_dt1+pom2*pom_dt2
6715 #ifdef DEBUG
6716         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6717 #endif
6718 !
6719 !
6720        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6721        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6722        cosfac2xx=cosfac2*xx
6723        sinfac2yy=sinfac2*yy
6724        do k = 1,3
6725          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6726             vbld_inv(i+1)
6727          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6728             vbld_inv(i)
6729          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6730          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6731 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6732 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6733 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6734 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6735          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6736          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6737          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6738          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6739          dZZ_Ci1(k)=0.0d0
6740          dZZ_Ci(k)=0.0d0
6741          do j=1,3
6742            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6743            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6744            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6745            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6746          enddo
6747
6748          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6749          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6750          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6751          (z_prime(k)-zz*dC_norm(k,i+nres))
6752 !
6753          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6754          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6755        enddo
6756
6757        do k=1,3
6758          dXX_Ctab(k,i)=dXX_Ci(k)
6759          dXX_C1tab(k,i)=dXX_Ci1(k)
6760          dYY_Ctab(k,i)=dYY_Ci(k)
6761          dYY_C1tab(k,i)=dYY_Ci1(k)
6762          dZZ_Ctab(k,i)=dZZ_Ci(k)
6763          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6764          dXX_XYZtab(k,i)=dXX_XYZ(k)
6765          dYY_XYZtab(k,i)=dYY_XYZ(k)
6766          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6767        enddo
6768
6769        do k = 1,3
6770 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6771 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6772 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6773 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6774 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6775 !     &    dt_dci(k)
6776 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6777 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6778          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6779           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6780          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6781           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6782          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6783           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6784        enddo
6785 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6786 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6787
6788 ! to check gradient call subroutine check_grad
6789
6790     1 continue
6791       enddo
6792       return
6793       end subroutine esc
6794 !-----------------------------------------------------------------------------
6795       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6796 !      implicit none
6797       real(kind=8),dimension(65) :: x
6798       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6799         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6800
6801       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6802         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6803         + x(10)*yy*zz
6804       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6805         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6806         + x(20)*yy*zz
6807       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6808         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6809         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6810         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6811         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6812         +x(40)*xx*yy*zz
6813       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6814         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6815         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6816         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6817         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6818         +x(60)*xx*yy*zz
6819       dsc_i   = 0.743d0+x(61)
6820       dp2_i   = 1.9d0+x(62)
6821       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6822                 *(xx*cost2+yy*sint2))
6823       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6824                 *(xx*cost2-yy*sint2))
6825       s1=(1+x(63))/(0.1d0 + dscp1)
6826       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6827       s2=(1+x(65))/(0.1d0 + dscp2)
6828       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6829       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6830        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6831       enesc=sumene
6832       return
6833       end function enesc
6834 #endif
6835 !-----------------------------------------------------------------------------
6836       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6837 !
6838 ! This procedure calculates two-body contact function g(rij) and its derivative:
6839 !
6840 !           eps0ij                                     !       x < -1
6841 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6842 !            0                                         !       x > 1
6843 !
6844 ! where x=(rij-r0ij)/delta
6845 !
6846 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6847 !
6848 !      implicit none
6849       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6850       real(kind=8) :: x,x2,x4,delta
6851 !     delta=0.02D0*r0ij
6852 !      delta=0.2D0*r0ij
6853       x=(rij-r0ij)/delta
6854       if (x.lt.-1.0D0) then
6855         fcont=eps0ij
6856         fprimcont=0.0D0
6857       else if (x.le.1.0D0) then
6858         x2=x*x
6859         x4=x2*x2
6860         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6861         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6862       else
6863         fcont=0.0D0
6864         fprimcont=0.0D0
6865       endif
6866       return
6867       end subroutine gcont
6868 !-----------------------------------------------------------------------------
6869       subroutine splinthet(theti,delta,ss,ssder)
6870 !      implicit real*8 (a-h,o-z)
6871 !      include 'DIMENSIONS'
6872 !      include 'COMMON.VAR'
6873 !      include 'COMMON.GEO'
6874       real(kind=8) :: theti,delta,ss,ssder
6875       real(kind=8) :: thetup,thetlow
6876       thetup=pi-delta
6877       thetlow=delta
6878       if (theti.gt.pipol) then
6879         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6880       else
6881         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6882         ssder=-ssder
6883       endif
6884       return
6885       end subroutine splinthet
6886 !-----------------------------------------------------------------------------
6887       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6888 !      implicit none
6889       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6890       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6891       a1=fprim0*delta/(f1-f0)
6892       a2=3.0d0-2.0d0*a1
6893       a3=a1-2.0d0
6894       ksi=(x-x0)/delta
6895       ksi2=ksi*ksi
6896       ksi3=ksi2*ksi
6897       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6898       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6899       return
6900       end subroutine spline1
6901 !-----------------------------------------------------------------------------
6902       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6903 !      implicit none
6904       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6905       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6906       ksi=(x-x0)/delta
6907       ksi2=ksi*ksi
6908       ksi3=ksi2*ksi
6909       a1=fprim0x*delta
6910       a2=3*(f1x-f0x)-2*fprim0x*delta
6911       a3=fprim0x*delta-2*(f1x-f0x)
6912       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6913       return
6914       end subroutine spline2
6915 !-----------------------------------------------------------------------------
6916 #ifdef CRYST_TOR
6917 !-----------------------------------------------------------------------------
6918       subroutine etor(etors,edihcnstr)
6919 !      implicit real*8 (a-h,o-z)
6920 !      include 'DIMENSIONS'
6921 !      include 'COMMON.VAR'
6922 !      include 'COMMON.GEO'
6923 !      include 'COMMON.LOCAL'
6924 !      include 'COMMON.TORSION'
6925 !      include 'COMMON.INTERACT'
6926 !      include 'COMMON.DERIV'
6927 !      include 'COMMON.CHAIN'
6928 !      include 'COMMON.NAMES'
6929 !      include 'COMMON.IOUNITS'
6930 !      include 'COMMON.FFIELD'
6931 !      include 'COMMON.TORCNSTR'
6932 !      include 'COMMON.CONTROL'
6933       real(kind=8) :: etors,edihcnstr
6934       logical :: lprn
6935 !el local variables
6936       integer :: i,j,
6937       real(kind=8) :: phii,fac,etors_ii
6938
6939 ! Set lprn=.true. for debugging
6940       lprn=.false.
6941 !      lprn=.true.
6942       etors=0.0D0
6943       do i=iphi_start,iphi_end
6944       etors_ii=0.0D0
6945         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
6946             .or. itype(i,1).eq.ntyp1) cycle
6947         itori=itortyp(itype(i-2,1))
6948         itori1=itortyp(itype(i-1,1))
6949         phii=phi(i)
6950         gloci=0.0D0
6951 ! Proline-Proline pair is a special case...
6952         if (itori.eq.3 .and. itori1.eq.3) then
6953           if (phii.gt.-dwapi3) then
6954             cosphi=dcos(3*phii)
6955             fac=1.0D0/(1.0D0-cosphi)
6956             etorsi=v1(1,3,3)*fac
6957             etorsi=etorsi+etorsi
6958             etors=etors+etorsi-v1(1,3,3)
6959             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6960             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6961           endif
6962           do j=1,3
6963             v1ij=v1(j+1,itori,itori1)
6964             v2ij=v2(j+1,itori,itori1)
6965             cosphi=dcos(j*phii)
6966             sinphi=dsin(j*phii)
6967             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6968             if (energy_dec) etors_ii=etors_ii+ &
6969                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6970             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6971           enddo
6972         else
6973           do j=1,nterm_old
6974             v1ij=v1(j,itori,itori1)
6975             v2ij=v2(j,itori,itori1)
6976             cosphi=dcos(j*phii)
6977             sinphi=dsin(j*phii)
6978             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6979             if (energy_dec) etors_ii=etors_ii+ &
6980                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6981             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6982           enddo
6983         endif
6984         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6985              'etor',i,etors_ii
6986         if (lprn) &
6987         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6988         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6989         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6990         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6991 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6992       enddo
6993 ! 6/20/98 - dihedral angle constraints
6994       edihcnstr=0.0d0
6995       do i=1,ndih_constr
6996         itori=idih_constr(i)
6997         phii=phi(itori)
6998         difi=phii-phi0(i)
6999         if (difi.gt.drange(i)) then
7000           difi=difi-drange(i)
7001           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7002           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7003         else if (difi.lt.-drange(i)) then
7004           difi=difi+drange(i)
7005           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7006           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7007         endif
7008 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
7009 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7010       enddo
7011 !      write (iout,*) 'edihcnstr',edihcnstr
7012       return
7013       end subroutine etor
7014 !-----------------------------------------------------------------------------
7015       subroutine etor_d(etors_d)
7016       real(kind=8) :: etors_d
7017       etors_d=0.0d0
7018       return
7019       end subroutine etor_d
7020 #else
7021 !-----------------------------------------------------------------------------
7022       subroutine etor(etors,edihcnstr)
7023 !      implicit real*8 (a-h,o-z)
7024 !      include 'DIMENSIONS'
7025 !      include 'COMMON.VAR'
7026 !      include 'COMMON.GEO'
7027 !      include 'COMMON.LOCAL'
7028 !      include 'COMMON.TORSION'
7029 !      include 'COMMON.INTERACT'
7030 !      include 'COMMON.DERIV'
7031 !      include 'COMMON.CHAIN'
7032 !      include 'COMMON.NAMES'
7033 !      include 'COMMON.IOUNITS'
7034 !      include 'COMMON.FFIELD'
7035 !      include 'COMMON.TORCNSTR'
7036 !      include 'COMMON.CONTROL'
7037       real(kind=8) :: etors,edihcnstr
7038       logical :: lprn
7039 !el local variables
7040       integer :: i,j,iblock,itori,itori1
7041       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
7042                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
7043 ! Set lprn=.true. for debugging
7044       lprn=.false.
7045 !     lprn=.true.
7046       etors=0.0D0
7047       do i=iphi_start,iphi_end
7048         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7049              .or. itype(i-3,1).eq.ntyp1 &
7050              .or. itype(i,1).eq.ntyp1) cycle
7051         etors_ii=0.0D0
7052          if (iabs(itype(i,1)).eq.20) then
7053          iblock=2
7054          else
7055          iblock=1
7056          endif
7057         itori=itortyp(itype(i-2,1))
7058         itori1=itortyp(itype(i-1,1))
7059         phii=phi(i)
7060         gloci=0.0D0
7061 ! Regular cosine and sine terms
7062         do j=1,nterm(itori,itori1,iblock)
7063           v1ij=v1(j,itori,itori1,iblock)
7064           v2ij=v2(j,itori,itori1,iblock)
7065           cosphi=dcos(j*phii)
7066           sinphi=dsin(j*phii)
7067           etors=etors+v1ij*cosphi+v2ij*sinphi
7068           if (energy_dec) etors_ii=etors_ii+ &
7069                      v1ij*cosphi+v2ij*sinphi
7070           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7071         enddo
7072 ! Lorentz terms
7073 !                         v1
7074 !  E = SUM ----------------------------------- - v1
7075 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7076 !
7077         cosphi=dcos(0.5d0*phii)
7078         sinphi=dsin(0.5d0*phii)
7079         do j=1,nlor(itori,itori1,iblock)
7080           vl1ij=vlor1(j,itori,itori1)
7081           vl2ij=vlor2(j,itori,itori1)
7082           vl3ij=vlor3(j,itori,itori1)
7083           pom=vl2ij*cosphi+vl3ij*sinphi
7084           pom1=1.0d0/(pom*pom+1.0d0)
7085           etors=etors+vl1ij*pom1
7086           if (energy_dec) etors_ii=etors_ii+ &
7087                      vl1ij*pom1
7088           pom=-pom*pom1*pom1
7089           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7090         enddo
7091 ! Subtract the constant term
7092         etors=etors-v0(itori,itori1,iblock)
7093           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7094                'etor',i,etors_ii-v0(itori,itori1,iblock)
7095         if (lprn) &
7096         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7097         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
7098         (v1(j,itori,itori1,iblock),j=1,6),&
7099         (v2(j,itori,itori1,iblock),j=1,6)
7100         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7101 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7102       enddo
7103 ! 6/20/98 - dihedral angle constraints
7104       edihcnstr=0.0d0
7105 !      do i=1,ndih_constr
7106       do i=idihconstr_start,idihconstr_end
7107         itori=idih_constr(i)
7108         phii=phi(itori)
7109         difi=pinorm(phii-phi0(i))
7110         if (difi.gt.drange(i)) then
7111           difi=difi-drange(i)
7112           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7113           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7114         else if (difi.lt.-drange(i)) then
7115           difi=difi+drange(i)
7116           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7117           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7118         else
7119           difi=0.0
7120         endif
7121 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
7122 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
7123 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
7124       enddo
7125 !d       write (iout,*) 'edihcnstr',edihcnstr
7126       return
7127       end subroutine etor
7128 !-----------------------------------------------------------------------------
7129       subroutine etor_d(etors_d)
7130 ! 6/23/01 Compute double torsional energy
7131 !      implicit real*8 (a-h,o-z)
7132 !      include 'DIMENSIONS'
7133 !      include 'COMMON.VAR'
7134 !      include 'COMMON.GEO'
7135 !      include 'COMMON.LOCAL'
7136 !      include 'COMMON.TORSION'
7137 !      include 'COMMON.INTERACT'
7138 !      include 'COMMON.DERIV'
7139 !      include 'COMMON.CHAIN'
7140 !      include 'COMMON.NAMES'
7141 !      include 'COMMON.IOUNITS'
7142 !      include 'COMMON.FFIELD'
7143 !      include 'COMMON.TORCNSTR'
7144       real(kind=8) :: etors_d,etors_d_ii
7145       logical :: lprn
7146 !el local variables
7147       integer :: i,j,k,l,itori,itori1,itori2,iblock
7148       real(kind=8) :: phii,phii1,gloci1,gloci2,&
7149                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
7150                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
7151                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
7152 ! Set lprn=.true. for debugging
7153       lprn=.false.
7154 !     lprn=.true.
7155       etors_d=0.0D0
7156 !      write(iout,*) "a tu??"
7157       do i=iphid_start,iphid_end
7158         etors_d_ii=0.0D0
7159         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
7160             .or. itype(i-3,1).eq.ntyp1 &
7161             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
7162         itori=itortyp(itype(i-2,1))
7163         itori1=itortyp(itype(i-1,1))
7164         itori2=itortyp(itype(i,1))
7165         phii=phi(i)
7166         phii1=phi(i+1)
7167         gloci1=0.0D0
7168         gloci2=0.0D0
7169         iblock=1
7170         if (iabs(itype(i+1,1)).eq.20) iblock=2
7171
7172 ! Regular cosine and sine terms
7173         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7174           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7175           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7176           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7177           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7178           cosphi1=dcos(j*phii)
7179           sinphi1=dsin(j*phii)
7180           cosphi2=dcos(j*phii1)
7181           sinphi2=dsin(j*phii1)
7182           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
7183            v2cij*cosphi2+v2sij*sinphi2
7184           if (energy_dec) etors_d_ii=etors_d_ii+ &
7185            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7186           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7187           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7188         enddo
7189         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7190           do l=1,k-1
7191             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7192             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7193             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7194             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7195             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7196             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7197             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7198             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7199             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7200               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7201             if (energy_dec) etors_d_ii=etors_d_ii+ &
7202               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7203               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7204             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7205               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7206             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7207               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7208           enddo
7209         enddo
7210         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7211                             'etor_d',i,etors_d_ii
7212         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7213         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7214       enddo
7215       return
7216       end subroutine etor_d
7217 #endif
7218 !-----------------------------------------------------------------------------
7219       subroutine eback_sc_corr(esccor)
7220 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
7221 !        conformational states; temporarily implemented as differences
7222 !        between UNRES torsional potentials (dependent on three types of
7223 !        residues) and the torsional potentials dependent on all 20 types
7224 !        of residues computed from AM1  energy surfaces of terminally-blocked
7225 !        amino-acid residues.
7226 !      implicit real*8 (a-h,o-z)
7227 !      include 'DIMENSIONS'
7228 !      include 'COMMON.VAR'
7229 !      include 'COMMON.GEO'
7230 !      include 'COMMON.LOCAL'
7231 !      include 'COMMON.TORSION'
7232 !      include 'COMMON.SCCOR'
7233 !      include 'COMMON.INTERACT'
7234 !      include 'COMMON.DERIV'
7235 !      include 'COMMON.CHAIN'
7236 !      include 'COMMON.NAMES'
7237 !      include 'COMMON.IOUNITS'
7238 !      include 'COMMON.FFIELD'
7239 !      include 'COMMON.CONTROL'
7240       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7241                    cosphi,sinphi
7242       logical :: lprn
7243       integer :: i,interty,j,isccori,isccori1,intertyp
7244 ! Set lprn=.true. for debugging
7245       lprn=.false.
7246 !      lprn=.true.
7247 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7248       esccor=0.0D0
7249       do i=itau_start,itau_end
7250         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7251         esccor_ii=0.0D0
7252         isccori=isccortyp(itype(i-2,1))
7253         isccori1=isccortyp(itype(i-1,1))
7254
7255 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7256         phii=phi(i)
7257         do intertyp=1,3 !intertyp
7258          esccor_ii=0.0D0
7259 !c Added 09 May 2012 (Adasko)
7260 !c  Intertyp means interaction type of backbone mainchain correlation:
7261 !   1 = SC...Ca...Ca...Ca
7262 !   2 = Ca...Ca...Ca...SC
7263 !   3 = SC...Ca...Ca...SCi
7264         gloci=0.0D0
7265         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7266             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7267             (itype(i-1,1).eq.ntyp1))) &
7268           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7269            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7270            .or.(itype(i,1).eq.ntyp1))) &
7271           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7272             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7273             (itype(i-3,1).eq.ntyp1)))) cycle
7274         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7275         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7276        cycle
7277        do j=1,nterm_sccor(isccori,isccori1)
7278           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7279           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7280           cosphi=dcos(j*tauangle(intertyp,i))
7281           sinphi=dsin(j*tauangle(intertyp,i))
7282           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7283           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7284           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7285         enddo
7286         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7287                                 'esccor',i,intertyp,esccor_ii
7288 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7289         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7290         if (lprn) &
7291         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7292         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7293         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7294         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7295         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7296        enddo !intertyp
7297       enddo
7298
7299       return
7300       end subroutine eback_sc_corr
7301 !-----------------------------------------------------------------------------
7302       subroutine multibody(ecorr)
7303 ! This subroutine calculates multi-body contributions to energy following
7304 ! the idea of Skolnick et al. If side chains I and J make a contact and
7305 ! at the same time side chains I+1 and J+1 make a contact, an extra
7306 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7307 !      implicit real*8 (a-h,o-z)
7308 !      include 'DIMENSIONS'
7309 !      include 'COMMON.IOUNITS'
7310 !      include 'COMMON.DERIV'
7311 !      include 'COMMON.INTERACT'
7312 !      include 'COMMON.CONTACTS'
7313       real(kind=8),dimension(3) :: gx,gx1
7314       logical :: lprn
7315       real(kind=8) :: ecorr
7316       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7317 ! Set lprn=.true. for debugging
7318       lprn=.false.
7319
7320       if (lprn) then
7321         write (iout,'(a)') 'Contact function values:'
7322         do i=nnt,nct-2
7323           write (iout,'(i2,20(1x,i2,f10.5))') &
7324               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7325         enddo
7326       endif
7327       ecorr=0.0D0
7328
7329 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7330 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7331       do i=nnt,nct
7332         do j=1,3
7333           gradcorr(j,i)=0.0D0
7334           gradxorr(j,i)=0.0D0
7335         enddo
7336       enddo
7337       do i=nnt,nct-2
7338
7339         DO ISHIFT = 3,4
7340
7341         i1=i+ishift
7342         num_conti=num_cont(i)
7343         num_conti1=num_cont(i1)
7344         do jj=1,num_conti
7345           j=jcont(jj,i)
7346           do kk=1,num_conti1
7347             j1=jcont(kk,i1)
7348             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7349 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7350 !d   &                   ' ishift=',ishift
7351 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7352 ! The system gains extra energy.
7353               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7354             endif   ! j1==j+-ishift
7355           enddo     ! kk
7356         enddo       ! jj
7357
7358         ENDDO ! ISHIFT
7359
7360       enddo         ! i
7361       return
7362       end subroutine multibody
7363 !-----------------------------------------------------------------------------
7364       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7365 !      implicit real*8 (a-h,o-z)
7366 !      include 'DIMENSIONS'
7367 !      include 'COMMON.IOUNITS'
7368 !      include 'COMMON.DERIV'
7369 !      include 'COMMON.INTERACT'
7370 !      include 'COMMON.CONTACTS'
7371       real(kind=8),dimension(3) :: gx,gx1
7372       logical :: lprn
7373       integer :: i,j,k,l,jj,kk,m,ll
7374       real(kind=8) :: eij,ekl
7375       lprn=.false.
7376       eij=facont(jj,i)
7377       ekl=facont(kk,k)
7378 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7379 ! Calculate the multi-body contribution to energy.
7380 ! Calculate multi-body contributions to the gradient.
7381 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7382 !d   & k,l,(gacont(m,kk,k),m=1,3)
7383       do m=1,3
7384         gx(m) =ekl*gacont(m,jj,i)
7385         gx1(m)=eij*gacont(m,kk,k)
7386         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7387         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7388         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7389         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7390       enddo
7391       do m=i,j-1
7392         do ll=1,3
7393           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7394         enddo
7395       enddo
7396       do m=k,l-1
7397         do ll=1,3
7398           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7399         enddo
7400       enddo
7401       esccorr=-eij*ekl
7402       return
7403       end function esccorr
7404 !-----------------------------------------------------------------------------
7405       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7406 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7407 !      implicit real*8 (a-h,o-z)
7408 !      include 'DIMENSIONS'
7409 !      include 'COMMON.IOUNITS'
7410 #ifdef MPI
7411       include "mpif.h"
7412 !      integer :: maxconts !max_cont=maxconts  =nres/4
7413       integer,parameter :: max_dim=26
7414       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7415       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7416 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7417 !el      common /przechowalnia/ zapas
7418       integer :: status(MPI_STATUS_SIZE)
7419       integer,dimension((nres/4)*2) :: req !maxconts*2
7420       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7421 #endif
7422 !      include 'COMMON.SETUP'
7423 !      include 'COMMON.FFIELD'
7424 !      include 'COMMON.DERIV'
7425 !      include 'COMMON.INTERACT'
7426 !      include 'COMMON.CONTACTS'
7427 !      include 'COMMON.CONTROL'
7428 !      include 'COMMON.LOCAL'
7429       real(kind=8),dimension(3) :: gx,gx1
7430       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7431       logical :: lprn,ldone
7432 !el local variables
7433       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7434               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7435
7436 ! Set lprn=.true. for debugging
7437       lprn=.true.
7438 #ifdef MPI
7439 !      maxconts=nres/4
7440       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7441       n_corr=0
7442       n_corr1=0
7443       if (nfgtasks.le.1) goto 30
7444       if (lprn) then
7445         write (iout,'(a)') 'Contact function values before RECEIVE:'
7446         do i=nnt,nct-2
7447           write (iout,'(2i3,50(1x,i2,f5.2))') &
7448           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7449           j=1,num_cont_hb(i))
7450         enddo
7451       endif
7452       call flush(iout)
7453       do i=1,ntask_cont_from
7454         ncont_recv(i)=0
7455       enddo
7456       do i=1,ntask_cont_to
7457         ncont_sent(i)=0
7458       enddo
7459 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7460 !     & ntask_cont_to
7461 ! Make the list of contacts to send to send to other procesors
7462 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7463 !      call flush(iout)
7464       do i=iturn3_start,iturn3_end
7465 !        write (iout,*) "make contact list turn3",i," num_cont",
7466 !     &    num_cont_hb(i)
7467         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7468       enddo
7469       do i=iturn4_start,iturn4_end
7470 !        write (iout,*) "make contact list turn4",i," num_cont",
7471 !     &   num_cont_hb(i)
7472         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7473       enddo
7474       do ii=1,nat_sent
7475         i=iat_sent(ii)
7476 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7477 !     &    num_cont_hb(i)
7478         do j=1,num_cont_hb(i)
7479         do k=1,4
7480           jjc=jcont_hb(j,i)
7481           iproc=iint_sent_local(k,jjc,ii)
7482 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7483           if (iproc.gt.0) then
7484             ncont_sent(iproc)=ncont_sent(iproc)+1
7485             nn=ncont_sent(iproc)
7486             zapas(1,nn,iproc)=i
7487             zapas(2,nn,iproc)=jjc
7488             zapas(3,nn,iproc)=facont_hb(j,i)
7489             zapas(4,nn,iproc)=ees0p(j,i)
7490             zapas(5,nn,iproc)=ees0m(j,i)
7491             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7492             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7493             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7494             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7495             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7496             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7497             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7498             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7499             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7500             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7501             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7502             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7503             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7504             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7505             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7506             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7507             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7508             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7509             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7510             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7511             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7512           endif
7513         enddo
7514         enddo
7515       enddo
7516       if (lprn) then
7517       write (iout,*) &
7518         "Numbers of contacts to be sent to other processors",&
7519         (ncont_sent(i),i=1,ntask_cont_to)
7520       write (iout,*) "Contacts sent"
7521       do ii=1,ntask_cont_to
7522         nn=ncont_sent(ii)
7523         iproc=itask_cont_to(ii)
7524         write (iout,*) nn," contacts to processor",iproc,&
7525          " of CONT_TO_COMM group"
7526         do i=1,nn
7527           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7528         enddo
7529       enddo
7530       call flush(iout)
7531       endif
7532       CorrelType=477
7533       CorrelID=fg_rank+1
7534       CorrelType1=478
7535       CorrelID1=nfgtasks+fg_rank+1
7536       ireq=0
7537 ! Receive the numbers of needed contacts from other processors
7538       do ii=1,ntask_cont_from
7539         iproc=itask_cont_from(ii)
7540         ireq=ireq+1
7541         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7542           FG_COMM,req(ireq),IERR)
7543       enddo
7544 !      write (iout,*) "IRECV ended"
7545 !      call flush(iout)
7546 ! Send the number of contacts needed by other processors
7547       do ii=1,ntask_cont_to
7548         iproc=itask_cont_to(ii)
7549         ireq=ireq+1
7550         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7551           FG_COMM,req(ireq),IERR)
7552       enddo
7553 !      write (iout,*) "ISEND ended"
7554 !      write (iout,*) "number of requests (nn)",ireq
7555       call flush(iout)
7556       if (ireq.gt.0) &
7557         call MPI_Waitall(ireq,req,status_array,ierr)
7558 !      write (iout,*)
7559 !     &  "Numbers of contacts to be received from other processors",
7560 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7561 !      call flush(iout)
7562 ! Receive contacts
7563       ireq=0
7564       do ii=1,ntask_cont_from
7565         iproc=itask_cont_from(ii)
7566         nn=ncont_recv(ii)
7567 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7568 !     &   " of CONT_TO_COMM group"
7569         call flush(iout)
7570         if (nn.gt.0) then
7571           ireq=ireq+1
7572           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7573           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7574 !          write (iout,*) "ireq,req",ireq,req(ireq)
7575         endif
7576       enddo
7577 ! Send the contacts to processors that need them
7578       do ii=1,ntask_cont_to
7579         iproc=itask_cont_to(ii)
7580         nn=ncont_sent(ii)
7581 !        write (iout,*) nn," contacts to processor",iproc,
7582 !     &   " of CONT_TO_COMM group"
7583         if (nn.gt.0) then
7584           ireq=ireq+1
7585           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7586             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7587 !          write (iout,*) "ireq,req",ireq,req(ireq)
7588 !          do i=1,nn
7589 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7590 !          enddo
7591         endif
7592       enddo
7593 !      write (iout,*) "number of requests (contacts)",ireq
7594 !      write (iout,*) "req",(req(i),i=1,4)
7595 !      call flush(iout)
7596       if (ireq.gt.0) &
7597        call MPI_Waitall(ireq,req,status_array,ierr)
7598       do iii=1,ntask_cont_from
7599         iproc=itask_cont_from(iii)
7600         nn=ncont_recv(iii)
7601         if (lprn) then
7602         write (iout,*) "Received",nn," contacts from processor",iproc,&
7603          " of CONT_FROM_COMM group"
7604         call flush(iout)
7605         do i=1,nn
7606           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7607         enddo
7608         call flush(iout)
7609         endif
7610         do i=1,nn
7611           ii=zapas_recv(1,i,iii)
7612 ! Flag the received contacts to prevent double-counting
7613           jj=-zapas_recv(2,i,iii)
7614 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7615 !          call flush(iout)
7616           nnn=num_cont_hb(ii)+1
7617           num_cont_hb(ii)=nnn
7618           jcont_hb(nnn,ii)=jj
7619           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7620           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7621           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7622           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7623           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7624           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7625           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7626           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7627           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7628           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7629           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7630           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7631           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7632           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7633           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7634           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7635           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7636           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7637           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7638           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7639           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7640           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7641           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7642           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7643         enddo
7644       enddo
7645       call flush(iout)
7646       if (lprn) then
7647         write (iout,'(a)') 'Contact function values after receive:'
7648         do i=nnt,nct-2
7649           write (iout,'(2i3,50(1x,i3,f5.2))') &
7650           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7651           j=1,num_cont_hb(i))
7652         enddo
7653         call flush(iout)
7654       endif
7655    30 continue
7656 #endif
7657       if (lprn) then
7658         write (iout,'(a)') 'Contact function values:'
7659         do i=nnt,nct-2
7660           write (iout,'(2i3,50(1x,i3,f5.2))') &
7661           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7662           j=1,num_cont_hb(i))
7663         enddo
7664       endif
7665       ecorr=0.0D0
7666
7667 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7668 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7669 ! Remove the loop below after debugging !!!
7670       do i=nnt,nct
7671         do j=1,3
7672           gradcorr(j,i)=0.0D0
7673           gradxorr(j,i)=0.0D0
7674         enddo
7675       enddo
7676 ! Calculate the local-electrostatic correlation terms
7677       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7678         i1=i+1
7679         num_conti=num_cont_hb(i)
7680         num_conti1=num_cont_hb(i+1)
7681         do jj=1,num_conti
7682           j=jcont_hb(jj,i)
7683           jp=iabs(j)
7684           do kk=1,num_conti1
7685             j1=jcont_hb(kk,i1)
7686             jp1=iabs(j1)
7687 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7688 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7689             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7690                 .or. j.lt.0 .and. j1.gt.0) .and. &
7691                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7692 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7693 ! The system gains extra energy.
7694               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7695               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7696                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7697               n_corr=n_corr+1
7698             else if (j1.eq.j) then
7699 ! Contacts I-J and I-(J+1) occur simultaneously.
7700 ! The system loses extra energy.
7701 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7702             endif
7703           enddo ! kk
7704           do kk=1,num_conti
7705             j1=jcont_hb(kk,i)
7706 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7707 !    &         ' jj=',jj,' kk=',kk
7708             if (j1.eq.j+1) then
7709 ! Contacts I-J and (I+1)-J occur simultaneously.
7710 ! The system loses extra energy.
7711 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7712             endif ! j1==j+1
7713           enddo ! kk
7714         enddo ! jj
7715       enddo ! i
7716       return
7717       end subroutine multibody_hb
7718 !-----------------------------------------------------------------------------
7719       subroutine add_hb_contact(ii,jj,itask)
7720 !      implicit real*8 (a-h,o-z)
7721 !      include "DIMENSIONS"
7722 !      include "COMMON.IOUNITS"
7723 !      include "COMMON.CONTACTS"
7724 !      integer,parameter :: maxconts=nres/4
7725       integer,parameter :: max_dim=26
7726       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7727 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7728 !      common /przechowalnia/ zapas
7729       integer :: i,j,ii,jj,iproc,nn,jjc
7730       integer,dimension(4) :: itask
7731 !      write (iout,*) "itask",itask
7732       do i=1,2
7733         iproc=itask(i)
7734         if (iproc.gt.0) then
7735           do j=1,num_cont_hb(ii)
7736             jjc=jcont_hb(j,ii)
7737 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7738             if (jjc.eq.jj) then
7739               ncont_sent(iproc)=ncont_sent(iproc)+1
7740               nn=ncont_sent(iproc)
7741               zapas(1,nn,iproc)=ii
7742               zapas(2,nn,iproc)=jjc
7743               zapas(3,nn,iproc)=facont_hb(j,ii)
7744               zapas(4,nn,iproc)=ees0p(j,ii)
7745               zapas(5,nn,iproc)=ees0m(j,ii)
7746               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7747               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7748               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7749               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7750               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7751               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7752               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7753               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7754               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7755               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7756               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7757               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7758               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7759               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7760               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7761               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7762               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7763               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7764               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7765               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7766               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7767               exit
7768             endif
7769           enddo
7770         endif
7771       enddo
7772       return
7773       end subroutine add_hb_contact
7774 !-----------------------------------------------------------------------------
7775       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7776 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7777 !      implicit real*8 (a-h,o-z)
7778 !      include 'DIMENSIONS'
7779 !      include 'COMMON.IOUNITS'
7780       integer,parameter :: max_dim=70
7781 #ifdef MPI
7782       include "mpif.h"
7783 !      integer :: maxconts !max_cont=maxconts=nres/4
7784       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7785       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7786 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7787 !      common /przechowalnia/ zapas
7788       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7789         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7790         ierr,iii,nnn
7791 #endif
7792 !      include 'COMMON.SETUP'
7793 !      include 'COMMON.FFIELD'
7794 !      include 'COMMON.DERIV'
7795 !      include 'COMMON.LOCAL'
7796 !      include 'COMMON.INTERACT'
7797 !      include 'COMMON.CONTACTS'
7798 !      include 'COMMON.CHAIN'
7799 !      include 'COMMON.CONTROL'
7800       real(kind=8),dimension(3) :: gx,gx1
7801       integer,dimension(nres) :: num_cont_hb_old
7802       logical :: lprn,ldone
7803 !EL      double precision eello4,eello5,eelo6,eello_turn6
7804 !EL      external eello4,eello5,eello6,eello_turn6
7805 !el local variables
7806       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7807               j1,jp1,i1,num_conti1
7808       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7809       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7810
7811 ! Set lprn=.true. for debugging
7812       lprn=.false.
7813       eturn6=0.0d0
7814 #ifdef MPI
7815 !      maxconts=nres/4
7816       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7817       do i=1,nres
7818         num_cont_hb_old(i)=num_cont_hb(i)
7819       enddo
7820       n_corr=0
7821       n_corr1=0
7822       if (nfgtasks.le.1) goto 30
7823       if (lprn) then
7824         write (iout,'(a)') 'Contact function values before RECEIVE:'
7825         do i=nnt,nct-2
7826           write (iout,'(2i3,50(1x,i2,f5.2))') &
7827           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7828           j=1,num_cont_hb(i))
7829         enddo
7830       endif
7831       call flush(iout)
7832       do i=1,ntask_cont_from
7833         ncont_recv(i)=0
7834       enddo
7835       do i=1,ntask_cont_to
7836         ncont_sent(i)=0
7837       enddo
7838 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7839 !     & ntask_cont_to
7840 ! Make the list of contacts to send to send to other procesors
7841       do i=iturn3_start,iturn3_end
7842 !        write (iout,*) "make contact list turn3",i," num_cont",
7843 !     &    num_cont_hb(i)
7844         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7845       enddo
7846       do i=iturn4_start,iturn4_end
7847 !        write (iout,*) "make contact list turn4",i," num_cont",
7848 !     &   num_cont_hb(i)
7849         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7850       enddo
7851       do ii=1,nat_sent
7852         i=iat_sent(ii)
7853 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7854 !     &    num_cont_hb(i)
7855         do j=1,num_cont_hb(i)
7856         do k=1,4
7857           jjc=jcont_hb(j,i)
7858           iproc=iint_sent_local(k,jjc,ii)
7859 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7860           if (iproc.ne.0) then
7861             ncont_sent(iproc)=ncont_sent(iproc)+1
7862             nn=ncont_sent(iproc)
7863             zapas(1,nn,iproc)=i
7864             zapas(2,nn,iproc)=jjc
7865             zapas(3,nn,iproc)=d_cont(j,i)
7866             ind=3
7867             do kk=1,3
7868               ind=ind+1
7869               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7870             enddo
7871             do kk=1,2
7872               do ll=1,2
7873                 ind=ind+1
7874                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7875               enddo
7876             enddo
7877             do jj=1,5
7878               do kk=1,3
7879                 do ll=1,2
7880                   do mm=1,2
7881                     ind=ind+1
7882                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7883                   enddo
7884                 enddo
7885               enddo
7886             enddo
7887           endif
7888         enddo
7889         enddo
7890       enddo
7891       if (lprn) then
7892       write (iout,*) &
7893         "Numbers of contacts to be sent to other processors",&
7894         (ncont_sent(i),i=1,ntask_cont_to)
7895       write (iout,*) "Contacts sent"
7896       do ii=1,ntask_cont_to
7897         nn=ncont_sent(ii)
7898         iproc=itask_cont_to(ii)
7899         write (iout,*) nn," contacts to processor",iproc,&
7900          " of CONT_TO_COMM group"
7901         do i=1,nn
7902           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7903         enddo
7904       enddo
7905       call flush(iout)
7906       endif
7907       CorrelType=477
7908       CorrelID=fg_rank+1
7909       CorrelType1=478
7910       CorrelID1=nfgtasks+fg_rank+1
7911       ireq=0
7912 ! Receive the numbers of needed contacts from other processors
7913       do ii=1,ntask_cont_from
7914         iproc=itask_cont_from(ii)
7915         ireq=ireq+1
7916         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7917           FG_COMM,req(ireq),IERR)
7918       enddo
7919 !      write (iout,*) "IRECV ended"
7920 !      call flush(iout)
7921 ! Send the number of contacts needed by other processors
7922       do ii=1,ntask_cont_to
7923         iproc=itask_cont_to(ii)
7924         ireq=ireq+1
7925         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7926           FG_COMM,req(ireq),IERR)
7927       enddo
7928 !      write (iout,*) "ISEND ended"
7929 !      write (iout,*) "number of requests (nn)",ireq
7930       call flush(iout)
7931       if (ireq.gt.0) &
7932         call MPI_Waitall(ireq,req,status_array,ierr)
7933 !      write (iout,*)
7934 !     &  "Numbers of contacts to be received from other processors",
7935 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7936 !      call flush(iout)
7937 ! Receive contacts
7938       ireq=0
7939       do ii=1,ntask_cont_from
7940         iproc=itask_cont_from(ii)
7941         nn=ncont_recv(ii)
7942 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7943 !     &   " of CONT_TO_COMM group"
7944         call flush(iout)
7945         if (nn.gt.0) then
7946           ireq=ireq+1
7947           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7948           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7949 !          write (iout,*) "ireq,req",ireq,req(ireq)
7950         endif
7951       enddo
7952 ! Send the contacts to processors that need them
7953       do ii=1,ntask_cont_to
7954         iproc=itask_cont_to(ii)
7955         nn=ncont_sent(ii)
7956 !        write (iout,*) nn," contacts to processor",iproc,
7957 !     &   " of CONT_TO_COMM group"
7958         if (nn.gt.0) then
7959           ireq=ireq+1
7960           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7961             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7962 !          write (iout,*) "ireq,req",ireq,req(ireq)
7963 !          do i=1,nn
7964 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7965 !          enddo
7966         endif
7967       enddo
7968 !      write (iout,*) "number of requests (contacts)",ireq
7969 !      write (iout,*) "req",(req(i),i=1,4)
7970 !      call flush(iout)
7971       if (ireq.gt.0) &
7972        call MPI_Waitall(ireq,req,status_array,ierr)
7973       do iii=1,ntask_cont_from
7974         iproc=itask_cont_from(iii)
7975         nn=ncont_recv(iii)
7976         if (lprn) then
7977         write (iout,*) "Received",nn," contacts from processor",iproc,&
7978          " of CONT_FROM_COMM group"
7979         call flush(iout)
7980         do i=1,nn
7981           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7982         enddo
7983         call flush(iout)
7984         endif
7985         do i=1,nn
7986           ii=zapas_recv(1,i,iii)
7987 ! Flag the received contacts to prevent double-counting
7988           jj=-zapas_recv(2,i,iii)
7989 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7990 !          call flush(iout)
7991           nnn=num_cont_hb(ii)+1
7992           num_cont_hb(ii)=nnn
7993           jcont_hb(nnn,ii)=jj
7994           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7995           ind=3
7996           do kk=1,3
7997             ind=ind+1
7998             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7999           enddo
8000           do kk=1,2
8001             do ll=1,2
8002               ind=ind+1
8003               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8004             enddo
8005           enddo
8006           do jj=1,5
8007             do kk=1,3
8008               do ll=1,2
8009                 do mm=1,2
8010                   ind=ind+1
8011                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8012                 enddo
8013               enddo
8014             enddo
8015           enddo
8016         enddo
8017       enddo
8018       call flush(iout)
8019       if (lprn) then
8020         write (iout,'(a)') 'Contact function values after receive:'
8021         do i=nnt,nct-2
8022           write (iout,'(2i3,50(1x,i3,5f6.3))') &
8023           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8024           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8025         enddo
8026         call flush(iout)
8027       endif
8028    30 continue
8029 #endif
8030       if (lprn) then
8031         write (iout,'(a)') 'Contact function values:'
8032         do i=nnt,nct-2
8033           write (iout,'(2i3,50(1x,i2,5f6.3))') &
8034           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
8035           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8036         enddo
8037       endif
8038       ecorr=0.0D0
8039       ecorr5=0.0d0
8040       ecorr6=0.0d0
8041
8042 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
8043 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
8044 ! Remove the loop below after debugging !!!
8045       do i=nnt,nct
8046         do j=1,3
8047           gradcorr(j,i)=0.0D0
8048           gradxorr(j,i)=0.0D0
8049         enddo
8050       enddo
8051 ! Calculate the dipole-dipole interaction energies
8052       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8053       do i=iatel_s,iatel_e+1
8054         num_conti=num_cont_hb(i)
8055         do jj=1,num_conti
8056           j=jcont_hb(jj,i)
8057 #ifdef MOMENT
8058           call dipole(i,j,jj)
8059 #endif
8060         enddo
8061       enddo
8062       endif
8063 ! Calculate the local-electrostatic correlation terms
8064 !                write (iout,*) "gradcorr5 in eello5 before loop"
8065 !                do iii=1,nres
8066 !                  write (iout,'(i5,3f10.5)')
8067 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8068 !                enddo
8069       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8070 !        write (iout,*) "corr loop i",i
8071         i1=i+1
8072         num_conti=num_cont_hb(i)
8073         num_conti1=num_cont_hb(i+1)
8074         do jj=1,num_conti
8075           j=jcont_hb(jj,i)
8076           jp=iabs(j)
8077           do kk=1,num_conti1
8078             j1=jcont_hb(kk,i1)
8079             jp1=iabs(j1)
8080 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8081 !     &         ' jj=',jj,' kk=',kk
8082 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
8083             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
8084                 .or. j.lt.0 .and. j1.gt.0) .and. &
8085                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8086 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8087 ! The system gains extra energy.
8088               n_corr=n_corr+1
8089               sqd1=dsqrt(d_cont(jj,i))
8090               sqd2=dsqrt(d_cont(kk,i1))
8091               sred_geom = sqd1*sqd2
8092               IF (sred_geom.lt.cutoff_corr) THEN
8093                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
8094                   ekont,fprimcont)
8095 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8096 !d     &         ' jj=',jj,' kk=',kk
8097                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8098                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8099                 do l=1,3
8100                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8101                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8102                 enddo
8103                 n_corr1=n_corr1+1
8104 !d               write (iout,*) 'sred_geom=',sred_geom,
8105 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
8106 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8107 !d               write (iout,*) "g_contij",g_contij
8108 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8109 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8110                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8111                 if (wcorr4.gt.0.0d0) &
8112                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8113                   if (energy_dec.and.wcorr4.gt.0.0d0) &
8114                        write (iout,'(a6,4i5,0pf7.3)') &
8115                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8116 !                write (iout,*) "gradcorr5 before eello5"
8117 !                do iii=1,nres
8118 !                  write (iout,'(i5,3f10.5)')
8119 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8120 !                enddo
8121                 if (wcorr5.gt.0.0d0) &
8122                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8123 !                write (iout,*) "gradcorr5 after eello5"
8124 !                do iii=1,nres
8125 !                  write (iout,'(i5,3f10.5)')
8126 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8127 !                enddo
8128                   if (energy_dec.and.wcorr5.gt.0.0d0) &
8129                        write (iout,'(a6,4i5,0pf7.3)') &
8130                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8131 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8132 !d                write(2,*)'ijkl',i,jp,i+1,jp1
8133                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
8134                      .or. wturn6.eq.0.0d0))then
8135 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8136                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8137                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8138                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8139 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8140 !d     &            'ecorr6=',ecorr6
8141 !d                write (iout,'(4e15.5)') sred_geom,
8142 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8143 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8144 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8145                 else if (wturn6.gt.0.0d0 &
8146                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8147 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8148                   eturn6=eturn6+eello_turn6(i,jj,kk)
8149                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
8150                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8151 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
8152                 endif
8153               ENDIF
8154 1111          continue
8155             endif
8156           enddo ! kk
8157         enddo ! jj
8158       enddo ! i
8159       do i=1,nres
8160         num_cont_hb(i)=num_cont_hb_old(i)
8161       enddo
8162 !                write (iout,*) "gradcorr5 in eello5"
8163 !                do iii=1,nres
8164 !                  write (iout,'(i5,3f10.5)')
8165 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8166 !                enddo
8167       return
8168       end subroutine multibody_eello
8169 !-----------------------------------------------------------------------------
8170       subroutine add_hb_contact_eello(ii,jj,itask)
8171 !      implicit real*8 (a-h,o-z)
8172 !      include "DIMENSIONS"
8173 !      include "COMMON.IOUNITS"
8174 !      include "COMMON.CONTACTS"
8175 !      integer,parameter :: maxconts=nres/4
8176       integer,parameter :: max_dim=70
8177       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
8178 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
8179 !      common /przechowalnia/ zapas
8180
8181       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
8182       integer,dimension(4) ::itask
8183 !      write (iout,*) "itask",itask
8184       do i=1,2
8185         iproc=itask(i)
8186         if (iproc.gt.0) then
8187           do j=1,num_cont_hb(ii)
8188             jjc=jcont_hb(j,ii)
8189 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8190             if (jjc.eq.jj) then
8191               ncont_sent(iproc)=ncont_sent(iproc)+1
8192               nn=ncont_sent(iproc)
8193               zapas(1,nn,iproc)=ii
8194               zapas(2,nn,iproc)=jjc
8195               zapas(3,nn,iproc)=d_cont(j,ii)
8196               ind=3
8197               do kk=1,3
8198                 ind=ind+1
8199                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8200               enddo
8201               do kk=1,2
8202                 do ll=1,2
8203                   ind=ind+1
8204                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8205                 enddo
8206               enddo
8207               do jj=1,5
8208                 do kk=1,3
8209                   do ll=1,2
8210                     do mm=1,2
8211                       ind=ind+1
8212                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8213                     enddo
8214                   enddo
8215                 enddo
8216               enddo
8217               exit
8218             endif
8219           enddo
8220         endif
8221       enddo
8222       return
8223       end subroutine add_hb_contact_eello
8224 !-----------------------------------------------------------------------------
8225       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8226 !      implicit real*8 (a-h,o-z)
8227 !      include 'DIMENSIONS'
8228 !      include 'COMMON.IOUNITS'
8229 !      include 'COMMON.DERIV'
8230 !      include 'COMMON.INTERACT'
8231 !      include 'COMMON.CONTACTS'
8232       real(kind=8),dimension(3) :: gx,gx1
8233       logical :: lprn
8234 !el local variables
8235       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8236       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8237                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8238                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8239                    rlocshield
8240
8241       lprn=.false.
8242       eij=facont_hb(jj,i)
8243       ekl=facont_hb(kk,k)
8244       ees0pij=ees0p(jj,i)
8245       ees0pkl=ees0p(kk,k)
8246       ees0mij=ees0m(jj,i)
8247       ees0mkl=ees0m(kk,k)
8248       ekont=eij*ekl
8249       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8250 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8251 ! Following 4 lines for diagnostics.
8252 !d    ees0pkl=0.0D0
8253 !d    ees0pij=1.0D0
8254 !d    ees0mkl=0.0D0
8255 !d    ees0mij=1.0D0
8256 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8257 !     & 'Contacts ',i,j,
8258 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8259 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8260 !     & 'gradcorr_long'
8261 ! Calculate the multi-body contribution to energy.
8262 !      ecorr=ecorr+ekont*ees
8263 ! Calculate multi-body contributions to the gradient.
8264       coeffpees0pij=coeffp*ees0pij
8265       coeffmees0mij=coeffm*ees0mij
8266       coeffpees0pkl=coeffp*ees0pkl
8267       coeffmees0mkl=coeffm*ees0mkl
8268       do ll=1,3
8269 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8270         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8271         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8272         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8273         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8274         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8275         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8276 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8277         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8278         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8279         coeffmees0mij*gacontm_hb1(ll,kk,k))
8280         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8281         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8282         coeffmees0mij*gacontm_hb2(ll,kk,k))
8283         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8284            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8285            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8286         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8287         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8288         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8289            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8290            coeffmees0mij*gacontm_hb3(ll,kk,k))
8291         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8292         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8293 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8294       enddo
8295 !      write (iout,*)
8296 !grad      do m=i+1,j-1
8297 !grad        do ll=1,3
8298 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8299 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8300 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8301 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8302 !grad        enddo
8303 !grad      enddo
8304 !grad      do m=k+1,l-1
8305 !grad        do ll=1,3
8306 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8307 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8308 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8309 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8310 !grad        enddo
8311 !grad      enddo
8312 !      write (iout,*) "ehbcorr",ekont*ees
8313       ehbcorr=ekont*ees
8314       if (shield_mode.gt.0) then
8315        j=ees0plist(jj,i)
8316        l=ees0plist(kk,k)
8317 !C        print *,i,j,fac_shield(i),fac_shield(j),
8318 !C     &fac_shield(k),fac_shield(l)
8319         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8320            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8321           do ilist=1,ishield_list(i)
8322            iresshield=shield_list(ilist,i)
8323            do m=1,3
8324            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8325            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8326                    rlocshield  &
8327             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8328             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8329             +rlocshield
8330            enddo
8331           enddo
8332           do ilist=1,ishield_list(j)
8333            iresshield=shield_list(ilist,j)
8334            do m=1,3
8335            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8336            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8337                    rlocshield &
8338             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8339            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8340             +rlocshield
8341            enddo
8342           enddo
8343
8344           do ilist=1,ishield_list(k)
8345            iresshield=shield_list(ilist,k)
8346            do m=1,3
8347            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8348            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8349                    rlocshield &
8350             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8351            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8352             +rlocshield
8353            enddo
8354           enddo
8355           do ilist=1,ishield_list(l)
8356            iresshield=shield_list(ilist,l)
8357            do m=1,3
8358            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8359            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8360                    rlocshield &
8361             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8362            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8363             +rlocshield
8364            enddo
8365           enddo
8366           do m=1,3
8367             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8368                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8369             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8370                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8371             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8372                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8373             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8374                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8375
8376             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8377                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8378             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8379                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8380             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8381                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8382             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8383                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8384
8385            enddo
8386       endif
8387       endif
8388       return
8389       end function ehbcorr
8390 #ifdef MOMENT
8391 !-----------------------------------------------------------------------------
8392       subroutine dipole(i,j,jj)
8393 !      implicit real*8 (a-h,o-z)
8394 !      include 'DIMENSIONS'
8395 !      include 'COMMON.IOUNITS'
8396 !      include 'COMMON.CHAIN'
8397 !      include 'COMMON.FFIELD'
8398 !      include 'COMMON.DERIV'
8399 !      include 'COMMON.INTERACT'
8400 !      include 'COMMON.CONTACTS'
8401 !      include 'COMMON.TORSION'
8402 !      include 'COMMON.VAR'
8403 !      include 'COMMON.GEO'
8404       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8405       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8406       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8407
8408       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8409       allocate(dipderx(3,5,4,maxconts,nres))
8410 !
8411
8412       iti1 = itortyp(itype(i+1,1))
8413       if (j.lt.nres-1) then
8414         itj1 = itortyp(itype(j+1,1))
8415       else
8416         itj1=ntortyp+1
8417       endif
8418       do iii=1,2
8419         dipi(iii,1)=Ub2(iii,i)
8420         dipderi(iii)=Ub2der(iii,i)
8421         dipi(iii,2)=b1(iii,iti1)
8422         dipj(iii,1)=Ub2(iii,j)
8423         dipderj(iii)=Ub2der(iii,j)
8424         dipj(iii,2)=b1(iii,itj1)
8425       enddo
8426       kkk=0
8427       do iii=1,2
8428         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8429         do jjj=1,2
8430           kkk=kkk+1
8431           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8432         enddo
8433       enddo
8434       do kkk=1,5
8435         do lll=1,3
8436           mmm=0
8437           do iii=1,2
8438             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8439               auxvec(1))
8440             do jjj=1,2
8441               mmm=mmm+1
8442               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8443             enddo
8444           enddo
8445         enddo
8446       enddo
8447       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8448       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8449       do iii=1,2
8450         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8451       enddo
8452       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8453       do iii=1,2
8454         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8455       enddo
8456       return
8457       end subroutine dipole
8458 #endif
8459 !-----------------------------------------------------------------------------
8460       subroutine calc_eello(i,j,k,l,jj,kk)
8461 !
8462 ! This subroutine computes matrices and vectors needed to calculate
8463 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8464 !
8465       use comm_kut
8466 !      implicit real*8 (a-h,o-z)
8467 !      include 'DIMENSIONS'
8468 !      include 'COMMON.IOUNITS'
8469 !      include 'COMMON.CHAIN'
8470 !      include 'COMMON.DERIV'
8471 !      include 'COMMON.INTERACT'
8472 !      include 'COMMON.CONTACTS'
8473 !      include 'COMMON.TORSION'
8474 !      include 'COMMON.VAR'
8475 !      include 'COMMON.GEO'
8476 !      include 'COMMON.FFIELD'
8477       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8478       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8479       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8480               itj1
8481 !el      logical :: lprn
8482 !el      common /kutas/ lprn
8483 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8484 !d     & ' jj=',jj,' kk=',kk
8485 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8486 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8487 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8488       do iii=1,2
8489         do jjj=1,2
8490           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8491           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8492         enddo
8493       enddo
8494       call transpose2(aa1(1,1),aa1t(1,1))
8495       call transpose2(aa2(1,1),aa2t(1,1))
8496       do kkk=1,5
8497         do lll=1,3
8498           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8499             aa1tder(1,1,lll,kkk))
8500           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8501             aa2tder(1,1,lll,kkk))
8502         enddo
8503       enddo
8504       if (l.eq.j+1) then
8505 ! parallel orientation of the two CA-CA-CA frames.
8506         if (i.gt.1) then
8507           iti=itortyp(itype(i,1))
8508         else
8509           iti=ntortyp+1
8510         endif
8511         itk1=itortyp(itype(k+1,1))
8512         itj=itortyp(itype(j,1))
8513         if (l.lt.nres-1) then
8514           itl1=itortyp(itype(l+1,1))
8515         else
8516           itl1=ntortyp+1
8517         endif
8518 ! A1 kernel(j+1) A2T
8519 !d        do iii=1,2
8520 !d          write (iout,'(3f10.5,5x,3f10.5)')
8521 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8522 !d        enddo
8523         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8524          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8525          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8526 ! Following matrices are needed only for 6-th order cumulants
8527         IF (wcorr6.gt.0.0d0) THEN
8528         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8529          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8530          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8531         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8532          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8533          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8534          ADtEAderx(1,1,1,1,1,1))
8535         lprn=.false.
8536         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8537          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8538          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8539          ADtEA1derx(1,1,1,1,1,1))
8540         ENDIF
8541 ! End 6-th order cumulants
8542 !d        lprn=.false.
8543 !d        if (lprn) then
8544 !d        write (2,*) 'In calc_eello6'
8545 !d        do iii=1,2
8546 !d          write (2,*) 'iii=',iii
8547 !d          do kkk=1,5
8548 !d            write (2,*) 'kkk=',kkk
8549 !d            do jjj=1,2
8550 !d              write (2,'(3(2f10.5),5x)')
8551 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8552 !d            enddo
8553 !d          enddo
8554 !d        enddo
8555 !d        endif
8556         call transpose2(EUgder(1,1,k),auxmat(1,1))
8557         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8558         call transpose2(EUg(1,1,k),auxmat(1,1))
8559         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8560         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8561         do iii=1,2
8562           do kkk=1,5
8563             do lll=1,3
8564               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8565                 EAEAderx(1,1,lll,kkk,iii,1))
8566             enddo
8567           enddo
8568         enddo
8569 ! A1T kernel(i+1) A2
8570         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8571          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8572          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8573 ! Following matrices are needed only for 6-th order cumulants
8574         IF (wcorr6.gt.0.0d0) THEN
8575         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8576          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8577          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8578         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8579          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8580          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8581          ADtEAderx(1,1,1,1,1,2))
8582         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8583          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8584          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8585          ADtEA1derx(1,1,1,1,1,2))
8586         ENDIF
8587 ! End 6-th order cumulants
8588         call transpose2(EUgder(1,1,l),auxmat(1,1))
8589         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8590         call transpose2(EUg(1,1,l),auxmat(1,1))
8591         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8592         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8593         do iii=1,2
8594           do kkk=1,5
8595             do lll=1,3
8596               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8597                 EAEAderx(1,1,lll,kkk,iii,2))
8598             enddo
8599           enddo
8600         enddo
8601 ! AEAb1 and AEAb2
8602 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8603 ! They are needed only when the fifth- or the sixth-order cumulants are
8604 ! indluded.
8605         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8606         call transpose2(AEA(1,1,1),auxmat(1,1))
8607         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8608         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8609         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8610         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8611         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8612         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8613         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8614         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8615         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8616         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8617         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8618         call transpose2(AEA(1,1,2),auxmat(1,1))
8619         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8620         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8621         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8622         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8623         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8624         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8625         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8626         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8627         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8628         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8629         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8630 ! Calculate the Cartesian derivatives of the vectors.
8631         do iii=1,2
8632           do kkk=1,5
8633             do lll=1,3
8634               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8635               call matvec2(auxmat(1,1),b1(1,iti),&
8636                 AEAb1derx(1,lll,kkk,iii,1,1))
8637               call matvec2(auxmat(1,1),Ub2(1,i),&
8638                 AEAb2derx(1,lll,kkk,iii,1,1))
8639               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8640                 AEAb1derx(1,lll,kkk,iii,2,1))
8641               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8642                 AEAb2derx(1,lll,kkk,iii,2,1))
8643               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8644               call matvec2(auxmat(1,1),b1(1,itj),&
8645                 AEAb1derx(1,lll,kkk,iii,1,2))
8646               call matvec2(auxmat(1,1),Ub2(1,j),&
8647                 AEAb2derx(1,lll,kkk,iii,1,2))
8648               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8649                 AEAb1derx(1,lll,kkk,iii,2,2))
8650               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8651                 AEAb2derx(1,lll,kkk,iii,2,2))
8652             enddo
8653           enddo
8654         enddo
8655         ENDIF
8656 ! End vectors
8657       else
8658 ! Antiparallel orientation of the two CA-CA-CA frames.
8659         if (i.gt.1) then
8660           iti=itortyp(itype(i,1))
8661         else
8662           iti=ntortyp+1
8663         endif
8664         itk1=itortyp(itype(k+1,1))
8665         itl=itortyp(itype(l,1))
8666         itj=itortyp(itype(j,1))
8667         if (j.lt.nres-1) then
8668           itj1=itortyp(itype(j+1,1))
8669         else
8670           itj1=ntortyp+1
8671         endif
8672 ! A2 kernel(j-1)T A1T
8673         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8674          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
8675          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8676 ! Following matrices are needed only for 6-th order cumulants
8677         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8678            j.eq.i+4 .and. l.eq.i+3)) THEN
8679         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8680          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8681          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8682         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8683          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8684          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8685          ADtEAderx(1,1,1,1,1,1))
8686         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8687          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8688          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8689          ADtEA1derx(1,1,1,1,1,1))
8690         ENDIF
8691 ! End 6-th order cumulants
8692         call transpose2(EUgder(1,1,k),auxmat(1,1))
8693         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8694         call transpose2(EUg(1,1,k),auxmat(1,1))
8695         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8696         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8697         do iii=1,2
8698           do kkk=1,5
8699             do lll=1,3
8700               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8701                 EAEAderx(1,1,lll,kkk,iii,1))
8702             enddo
8703           enddo
8704         enddo
8705 ! A2T kernel(i+1)T A1
8706         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8707          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
8708          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8709 ! Following matrices are needed only for 6-th order cumulants
8710         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8711            j.eq.i+4 .and. l.eq.i+3)) THEN
8712         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8713          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8714          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8715         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8716          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8717          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8718          ADtEAderx(1,1,1,1,1,2))
8719         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8720          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8721          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8722          ADtEA1derx(1,1,1,1,1,2))
8723         ENDIF
8724 ! End 6-th order cumulants
8725         call transpose2(EUgder(1,1,j),auxmat(1,1))
8726         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8727         call transpose2(EUg(1,1,j),auxmat(1,1))
8728         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8729         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8730         do iii=1,2
8731           do kkk=1,5
8732             do lll=1,3
8733               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8734                 EAEAderx(1,1,lll,kkk,iii,2))
8735             enddo
8736           enddo
8737         enddo
8738 ! AEAb1 and AEAb2
8739 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8740 ! They are needed only when the fifth- or the sixth-order cumulants are
8741 ! indluded.
8742         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8743           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8744         call transpose2(AEA(1,1,1),auxmat(1,1))
8745         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8746         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8747         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8748         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8749         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8750         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8751         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8752         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8753         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8754         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8755         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8756         call transpose2(AEA(1,1,2),auxmat(1,1))
8757         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8758         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8759         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8760         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8761         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8762         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8763         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8764         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8765         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8766         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8767         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8768 ! Calculate the Cartesian derivatives of the vectors.
8769         do iii=1,2
8770           do kkk=1,5
8771             do lll=1,3
8772               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8773               call matvec2(auxmat(1,1),b1(1,iti),&
8774                 AEAb1derx(1,lll,kkk,iii,1,1))
8775               call matvec2(auxmat(1,1),Ub2(1,i),&
8776                 AEAb2derx(1,lll,kkk,iii,1,1))
8777               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8778                 AEAb1derx(1,lll,kkk,iii,2,1))
8779               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8780                 AEAb2derx(1,lll,kkk,iii,2,1))
8781               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8782               call matvec2(auxmat(1,1),b1(1,itl),&
8783                 AEAb1derx(1,lll,kkk,iii,1,2))
8784               call matvec2(auxmat(1,1),Ub2(1,l),&
8785                 AEAb2derx(1,lll,kkk,iii,1,2))
8786               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8787                 AEAb1derx(1,lll,kkk,iii,2,2))
8788               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8789                 AEAb2derx(1,lll,kkk,iii,2,2))
8790             enddo
8791           enddo
8792         enddo
8793         ENDIF
8794 ! End vectors
8795       endif
8796       return
8797       end subroutine calc_eello
8798 !-----------------------------------------------------------------------------
8799       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8800       use comm_kut
8801       implicit none
8802       integer :: nderg
8803       logical :: transp
8804       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8805       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8806       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8807       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8808       integer :: iii,kkk,lll
8809       integer :: jjj,mmm
8810 !el      logical :: lprn
8811 !el      common /kutas/ lprn
8812       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8813       do iii=1,nderg
8814         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8815           AKAderg(1,1,iii))
8816       enddo
8817 !d      if (lprn) write (2,*) 'In kernel'
8818       do kkk=1,5
8819 !d        if (lprn) write (2,*) 'kkk=',kkk
8820         do lll=1,3
8821           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8822             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8823 !d          if (lprn) then
8824 !d            write (2,*) 'lll=',lll
8825 !d            write (2,*) 'iii=1'
8826 !d            do jjj=1,2
8827 !d              write (2,'(3(2f10.5),5x)')
8828 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8829 !d            enddo
8830 !d          endif
8831           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8832             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8833 !d          if (lprn) then
8834 !d            write (2,*) 'lll=',lll
8835 !d            write (2,*) 'iii=2'
8836 !d            do jjj=1,2
8837 !d              write (2,'(3(2f10.5),5x)')
8838 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8839 !d            enddo
8840 !d          endif
8841         enddo
8842       enddo
8843       return
8844       end subroutine kernel
8845 !-----------------------------------------------------------------------------
8846       real(kind=8) function eello4(i,j,k,l,jj,kk)
8847 !      implicit real*8 (a-h,o-z)
8848 !      include 'DIMENSIONS'
8849 !      include 'COMMON.IOUNITS'
8850 !      include 'COMMON.CHAIN'
8851 !      include 'COMMON.DERIV'
8852 !      include 'COMMON.INTERACT'
8853 !      include 'COMMON.CONTACTS'
8854 !      include 'COMMON.TORSION'
8855 !      include 'COMMON.VAR'
8856 !      include 'COMMON.GEO'
8857       real(kind=8),dimension(2,2) :: pizda
8858       real(kind=8),dimension(3) :: ggg1,ggg2
8859       real(kind=8) ::  eel4,glongij,glongkl
8860       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8861 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8862 !d        eello4=0.0d0
8863 !d        return
8864 !d      endif
8865 !d      print *,'eello4:',i,j,k,l,jj,kk
8866 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8867 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8868 !old      eij=facont_hb(jj,i)
8869 !old      ekl=facont_hb(kk,k)
8870 !old      ekont=eij*ekl
8871       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8872 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8873       gcorr_loc(k-1)=gcorr_loc(k-1) &
8874          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8875       if (l.eq.j+1) then
8876         gcorr_loc(l-1)=gcorr_loc(l-1) &
8877            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8878       else
8879         gcorr_loc(j-1)=gcorr_loc(j-1) &
8880            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8881       endif
8882       do iii=1,2
8883         do kkk=1,5
8884           do lll=1,3
8885             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8886                               -EAEAderx(2,2,lll,kkk,iii,1)
8887 !d            derx(lll,kkk,iii)=0.0d0
8888           enddo
8889         enddo
8890       enddo
8891 !d      gcorr_loc(l-1)=0.0d0
8892 !d      gcorr_loc(j-1)=0.0d0
8893 !d      gcorr_loc(k-1)=0.0d0
8894 !d      eel4=1.0d0
8895 !d      write (iout,*)'Contacts have occurred for peptide groups',
8896 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8897 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8898       if (j.lt.nres-1) then
8899         j1=j+1
8900         j2=j-1
8901       else
8902         j1=j-1
8903         j2=j-2
8904       endif
8905       if (l.lt.nres-1) then
8906         l1=l+1
8907         l2=l-1
8908       else
8909         l1=l-1
8910         l2=l-2
8911       endif
8912       do ll=1,3
8913 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8914 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8915         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8916         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8917 !grad        ghalf=0.5d0*ggg1(ll)
8918         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8919         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8920         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8921         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8922         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8923         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8924 !grad        ghalf=0.5d0*ggg2(ll)
8925         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8926         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8927         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8928         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8929         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8930         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8931       enddo
8932 !grad      do m=i+1,j-1
8933 !grad        do ll=1,3
8934 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8935 !grad        enddo
8936 !grad      enddo
8937 !grad      do m=k+1,l-1
8938 !grad        do ll=1,3
8939 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8940 !grad        enddo
8941 !grad      enddo
8942 !grad      do m=i+2,j2
8943 !grad        do ll=1,3
8944 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8945 !grad        enddo
8946 !grad      enddo
8947 !grad      do m=k+2,l2
8948 !grad        do ll=1,3
8949 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8950 !grad        enddo
8951 !grad      enddo
8952 !d      do iii=1,nres-3
8953 !d        write (2,*) iii,gcorr_loc(iii)
8954 !d      enddo
8955       eello4=ekont*eel4
8956 !d      write (2,*) 'ekont',ekont
8957 !d      write (iout,*) 'eello4',ekont*eel4
8958       return
8959       end function eello4
8960 !-----------------------------------------------------------------------------
8961       real(kind=8) function eello5(i,j,k,l,jj,kk)
8962 !      implicit real*8 (a-h,o-z)
8963 !      include 'DIMENSIONS'
8964 !      include 'COMMON.IOUNITS'
8965 !      include 'COMMON.CHAIN'
8966 !      include 'COMMON.DERIV'
8967 !      include 'COMMON.INTERACT'
8968 !      include 'COMMON.CONTACTS'
8969 !      include 'COMMON.TORSION'
8970 !      include 'COMMON.VAR'
8971 !      include 'COMMON.GEO'
8972       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8973       real(kind=8),dimension(2) :: vv
8974       real(kind=8),dimension(3) :: ggg1,ggg2
8975       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8976       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8977       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8978 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8979 !                                                                              C
8980 !                            Parallel chains                                   C
8981 !                                                                              C
8982 !          o             o                   o             o                   C
8983 !         /l\           / \             \   / \           / \   /              C
8984 !        /   \         /   \             \ /   \         /   \ /               C
8985 !       j| o |l1       | o |                o| o |         | o |o                C
8986 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8987 !      \i/   \         /   \ /             /   \         /   \                 C
8988 !       o    k1             o                                                  C
8989 !         (I)          (II)                (III)          (IV)                 C
8990 !                                                                              C
8991 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8992 !                                                                              C
8993 !                            Antiparallel chains                               C
8994 !                                                                              C
8995 !          o             o                   o             o                   C
8996 !         /j\           / \             \   / \           / \   /              C
8997 !        /   \         /   \             \ /   \         /   \ /               C
8998 !      j1| o |l        | o |                o| o |         | o |o                C
8999 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9000 !      \i/   \         /   \ /             /   \         /   \                 C
9001 !       o     k1            o                                                  C
9002 !         (I)          (II)                (III)          (IV)                 C
9003 !                                                                              C
9004 !      eello5_1        eello5_2            eello5_3       eello5_4             C
9005 !                                                                              C
9006 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
9007 !                                                                              C
9008 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9009 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9010 !d        eello5=0.0d0
9011 !d        return
9012 !d      endif
9013 !d      write (iout,*)
9014 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9015 !d     &   ' and',k,l
9016       itk=itortyp(itype(k,1))
9017       itl=itortyp(itype(l,1))
9018       itj=itortyp(itype(j,1))
9019       eello5_1=0.0d0
9020       eello5_2=0.0d0
9021       eello5_3=0.0d0
9022       eello5_4=0.0d0
9023 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9024 !d     &   eel5_3_num,eel5_4_num)
9025       do iii=1,2
9026         do kkk=1,5
9027           do lll=1,3
9028             derx(lll,kkk,iii)=0.0d0
9029           enddo
9030         enddo
9031       enddo
9032 !d      eij=facont_hb(jj,i)
9033 !d      ekl=facont_hb(kk,k)
9034 !d      ekont=eij*ekl
9035 !d      write (iout,*)'Contacts have occurred for peptide groups',
9036 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
9037 !d      goto 1111
9038 ! Contribution from the graph I.
9039 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9040 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9041       call transpose2(EUg(1,1,k),auxmat(1,1))
9042       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9043       vv(1)=pizda(1,1)-pizda(2,2)
9044       vv(2)=pizda(1,2)+pizda(2,1)
9045       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
9046        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9047 ! Explicit gradient in virtual-dihedral angles.
9048       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
9049        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
9050        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9051       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9052       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9053       vv(1)=pizda(1,1)-pizda(2,2)
9054       vv(2)=pizda(1,2)+pizda(2,1)
9055       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9056        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
9057        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9058       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9059       vv(1)=pizda(1,1)-pizda(2,2)
9060       vv(2)=pizda(1,2)+pizda(2,1)
9061       if (l.eq.j+1) then
9062         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9063          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9064          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9065       else
9066         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9067          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
9068          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9069       endif
9070 ! Cartesian gradient
9071       do iii=1,2
9072         do kkk=1,5
9073           do lll=1,3
9074             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9075               pizda(1,1))
9076             vv(1)=pizda(1,1)-pizda(2,2)
9077             vv(2)=pizda(1,2)+pizda(2,1)
9078             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9079              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
9080              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9081           enddo
9082         enddo
9083       enddo
9084 !      goto 1112
9085 !1111  continue
9086 ! Contribution from graph II
9087       call transpose2(EE(1,1,itk),auxmat(1,1))
9088       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9089       vv(1)=pizda(1,1)+pizda(2,2)
9090       vv(2)=pizda(2,1)-pizda(1,2)
9091       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
9092        -0.5d0*scalar2(vv(1),Ctobr(1,k))
9093 ! Explicit gradient in virtual-dihedral angles.
9094       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9095        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9096       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9097       vv(1)=pizda(1,1)+pizda(2,2)
9098       vv(2)=pizda(2,1)-pizda(1,2)
9099       if (l.eq.j+1) then
9100         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9101          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9102          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9103       else
9104         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9105          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
9106          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9107       endif
9108 ! Cartesian gradient
9109       do iii=1,2
9110         do kkk=1,5
9111           do lll=1,3
9112             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
9113               pizda(1,1))
9114             vv(1)=pizda(1,1)+pizda(2,2)
9115             vv(2)=pizda(2,1)-pizda(1,2)
9116             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9117              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
9118              -0.5d0*scalar2(vv(1),Ctobr(1,k))
9119           enddo
9120         enddo
9121       enddo
9122 !d      goto 1112
9123 !d1111  continue
9124       if (l.eq.j+1) then
9125 !d        goto 1110
9126 ! Parallel orientation
9127 ! Contribution from graph III
9128         call transpose2(EUg(1,1,l),auxmat(1,1))
9129         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9130         vv(1)=pizda(1,1)-pizda(2,2)
9131         vv(2)=pizda(1,2)+pizda(2,1)
9132         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
9133          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9134 ! Explicit gradient in virtual-dihedral angles.
9135         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9136          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
9137          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9138         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9139         vv(1)=pizda(1,1)-pizda(2,2)
9140         vv(2)=pizda(1,2)+pizda(2,1)
9141         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9142          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
9143          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9144         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9145         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9146         vv(1)=pizda(1,1)-pizda(2,2)
9147         vv(2)=pizda(1,2)+pizda(2,1)
9148         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9149          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
9150          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9151 ! Cartesian gradient
9152         do iii=1,2
9153           do kkk=1,5
9154             do lll=1,3
9155               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9156                 pizda(1,1))
9157               vv(1)=pizda(1,1)-pizda(2,2)
9158               vv(2)=pizda(1,2)+pizda(2,1)
9159               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9160                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
9161                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9162             enddo
9163           enddo
9164         enddo
9165 !d        goto 1112
9166 ! Contribution from graph IV
9167 !d1110    continue
9168         call transpose2(EE(1,1,itl),auxmat(1,1))
9169         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9170         vv(1)=pizda(1,1)+pizda(2,2)
9171         vv(2)=pizda(2,1)-pizda(1,2)
9172         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
9173          -0.5d0*scalar2(vv(1),Ctobr(1,l))
9174 ! Explicit gradient in virtual-dihedral angles.
9175         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9176          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9177         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9178         vv(1)=pizda(1,1)+pizda(2,2)
9179         vv(2)=pizda(2,1)-pizda(1,2)
9180         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9181          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
9182          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9183 ! Cartesian gradient
9184         do iii=1,2
9185           do kkk=1,5
9186             do lll=1,3
9187               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9188                 pizda(1,1))
9189               vv(1)=pizda(1,1)+pizda(2,2)
9190               vv(2)=pizda(2,1)-pizda(1,2)
9191               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9192                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
9193                -0.5d0*scalar2(vv(1),Ctobr(1,l))
9194             enddo
9195           enddo
9196         enddo
9197       else
9198 ! Antiparallel orientation
9199 ! Contribution from graph III
9200 !        goto 1110
9201         call transpose2(EUg(1,1,j),auxmat(1,1))
9202         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9203         vv(1)=pizda(1,1)-pizda(2,2)
9204         vv(2)=pizda(1,2)+pizda(2,1)
9205         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
9206          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9207 ! Explicit gradient in virtual-dihedral angles.
9208         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9209          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
9210          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9211         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9212         vv(1)=pizda(1,1)-pizda(2,2)
9213         vv(2)=pizda(1,2)+pizda(2,1)
9214         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9215          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
9216          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9217         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9218         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9219         vv(1)=pizda(1,1)-pizda(2,2)
9220         vv(2)=pizda(1,2)+pizda(2,1)
9221         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9222          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
9223          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9224 ! Cartesian gradient
9225         do iii=1,2
9226           do kkk=1,5
9227             do lll=1,3
9228               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9229                 pizda(1,1))
9230               vv(1)=pizda(1,1)-pizda(2,2)
9231               vv(2)=pizda(1,2)+pizda(2,1)
9232               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9233                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9234                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9235             enddo
9236           enddo
9237         enddo
9238 !d        goto 1112
9239 ! Contribution from graph IV
9240 1110    continue
9241         call transpose2(EE(1,1,itj),auxmat(1,1))
9242         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9243         vv(1)=pizda(1,1)+pizda(2,2)
9244         vv(2)=pizda(2,1)-pizda(1,2)
9245         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9246          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9247 ! Explicit gradient in virtual-dihedral angles.
9248         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9249          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9250         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9251         vv(1)=pizda(1,1)+pizda(2,2)
9252         vv(2)=pizda(2,1)-pizda(1,2)
9253         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9254          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9255          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9256 ! Cartesian gradient
9257         do iii=1,2
9258           do kkk=1,5
9259             do lll=1,3
9260               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9261                 pizda(1,1))
9262               vv(1)=pizda(1,1)+pizda(2,2)
9263               vv(2)=pizda(2,1)-pizda(1,2)
9264               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9265                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9266                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9267             enddo
9268           enddo
9269         enddo
9270       endif
9271 1112  continue
9272       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9273 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9274 !d        write (2,*) 'ijkl',i,j,k,l
9275 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9276 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9277 !d      endif
9278 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9279 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9280 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9281 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9282       if (j.lt.nres-1) then
9283         j1=j+1
9284         j2=j-1
9285       else
9286         j1=j-1
9287         j2=j-2
9288       endif
9289       if (l.lt.nres-1) then
9290         l1=l+1
9291         l2=l-1
9292       else
9293         l1=l-1
9294         l2=l-2
9295       endif
9296 !d      eij=1.0d0
9297 !d      ekl=1.0d0
9298 !d      ekont=1.0d0
9299 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9300 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9301 !        summed up outside the subrouine as for the other subroutines
9302 !        handling long-range interactions. The old code is commented out
9303 !        with "cgrad" to keep track of changes.
9304       do ll=1,3
9305 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9306 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9307         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9308         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9309 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9310 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9311 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9312 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9313 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9314 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9315 !     &   gradcorr5ij,
9316 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9317 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9318 !grad        ghalf=0.5d0*ggg1(ll)
9319 !d        ghalf=0.0d0
9320         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9321         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9322         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9323         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9324         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9325         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9326 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9327 !grad        ghalf=0.5d0*ggg2(ll)
9328         ghalf=0.0d0
9329         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9330         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9331         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9332         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9333         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9334         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9335       enddo
9336 !d      goto 1112
9337 !grad      do m=i+1,j-1
9338 !grad        do ll=1,3
9339 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9340 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9341 !grad        enddo
9342 !grad      enddo
9343 !grad      do m=k+1,l-1
9344 !grad        do ll=1,3
9345 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9346 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9347 !grad        enddo
9348 !grad      enddo
9349 !1112  continue
9350 !grad      do m=i+2,j2
9351 !grad        do ll=1,3
9352 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9353 !grad        enddo
9354 !grad      enddo
9355 !grad      do m=k+2,l2
9356 !grad        do ll=1,3
9357 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9358 !grad        enddo
9359 !grad      enddo
9360 !d      do iii=1,nres-3
9361 !d        write (2,*) iii,g_corr5_loc(iii)
9362 !d      enddo
9363       eello5=ekont*eel5
9364 !d      write (2,*) 'ekont',ekont
9365 !d      write (iout,*) 'eello5',ekont*eel5
9366       return
9367       end function eello5
9368 !-----------------------------------------------------------------------------
9369       real(kind=8) function eello6(i,j,k,l,jj,kk)
9370 !      implicit real*8 (a-h,o-z)
9371 !      include 'DIMENSIONS'
9372 !      include 'COMMON.IOUNITS'
9373 !      include 'COMMON.CHAIN'
9374 !      include 'COMMON.DERIV'
9375 !      include 'COMMON.INTERACT'
9376 !      include 'COMMON.CONTACTS'
9377 !      include 'COMMON.TORSION'
9378 !      include 'COMMON.VAR'
9379 !      include 'COMMON.GEO'
9380 !      include 'COMMON.FFIELD'
9381       real(kind=8),dimension(3) :: ggg1,ggg2
9382       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9383                    eello6_6,eel6
9384       real(kind=8) :: gradcorr6ij,gradcorr6kl
9385       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9386 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9387 !d        eello6=0.0d0
9388 !d        return
9389 !d      endif
9390 !d      write (iout,*)
9391 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9392 !d     &   ' and',k,l
9393       eello6_1=0.0d0
9394       eello6_2=0.0d0
9395       eello6_3=0.0d0
9396       eello6_4=0.0d0
9397       eello6_5=0.0d0
9398       eello6_6=0.0d0
9399 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9400 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9401       do iii=1,2
9402         do kkk=1,5
9403           do lll=1,3
9404             derx(lll,kkk,iii)=0.0d0
9405           enddo
9406         enddo
9407       enddo
9408 !d      eij=facont_hb(jj,i)
9409 !d      ekl=facont_hb(kk,k)
9410 !d      ekont=eij*ekl
9411 !d      eij=1.0d0
9412 !d      ekl=1.0d0
9413 !d      ekont=1.0d0
9414       if (l.eq.j+1) then
9415         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9416         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9417         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9418         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9419         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9420         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9421       else
9422         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9423         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9424         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9425         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9426         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9427           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9428         else
9429           eello6_5=0.0d0
9430         endif
9431         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9432       endif
9433 ! If turn contributions are considered, they will be handled separately.
9434       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9435 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9436 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9437 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9438 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9439 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9440 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9441 !d      goto 1112
9442       if (j.lt.nres-1) then
9443         j1=j+1
9444         j2=j-1
9445       else
9446         j1=j-1
9447         j2=j-2
9448       endif
9449       if (l.lt.nres-1) then
9450         l1=l+1
9451         l2=l-1
9452       else
9453         l1=l-1
9454         l2=l-2
9455       endif
9456       do ll=1,3
9457 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9458 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9459 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9460 !grad        ghalf=0.5d0*ggg1(ll)
9461 !d        ghalf=0.0d0
9462         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9463         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9464         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9465         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9466         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9467         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9468         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9469         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9470 !grad        ghalf=0.5d0*ggg2(ll)
9471 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9472 !d        ghalf=0.0d0
9473         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9474         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9475         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9476         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9477         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9478         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9479       enddo
9480 !d      goto 1112
9481 !grad      do m=i+1,j-1
9482 !grad        do ll=1,3
9483 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9484 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9485 !grad        enddo
9486 !grad      enddo
9487 !grad      do m=k+1,l-1
9488 !grad        do ll=1,3
9489 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9490 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9491 !grad        enddo
9492 !grad      enddo
9493 !grad1112  continue
9494 !grad      do m=i+2,j2
9495 !grad        do ll=1,3
9496 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9497 !grad        enddo
9498 !grad      enddo
9499 !grad      do m=k+2,l2
9500 !grad        do ll=1,3
9501 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9502 !grad        enddo
9503 !grad      enddo
9504 !d      do iii=1,nres-3
9505 !d        write (2,*) iii,g_corr6_loc(iii)
9506 !d      enddo
9507       eello6=ekont*eel6
9508 !d      write (2,*) 'ekont',ekont
9509 !d      write (iout,*) 'eello6',ekont*eel6
9510       return
9511       end function eello6
9512 !-----------------------------------------------------------------------------
9513       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9514       use comm_kut
9515 !      implicit real*8 (a-h,o-z)
9516 !      include 'DIMENSIONS'
9517 !      include 'COMMON.IOUNITS'
9518 !      include 'COMMON.CHAIN'
9519 !      include 'COMMON.DERIV'
9520 !      include 'COMMON.INTERACT'
9521 !      include 'COMMON.CONTACTS'
9522 !      include 'COMMON.TORSION'
9523 !      include 'COMMON.VAR'
9524 !      include 'COMMON.GEO'
9525       real(kind=8),dimension(2) :: vv,vv1
9526       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9527       logical :: swap
9528 !el      logical :: lprn
9529 !el      common /kutas/ lprn
9530       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9531       real(kind=8) :: s1,s2,s3,s4,s5
9532 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9533 !                                                                              C
9534 !      Parallel       Antiparallel                                             C
9535 !                                                                              C
9536 !          o             o                                                     C
9537 !         /l\           /j\                                                    C
9538 !        /   \         /   \                                                   C
9539 !       /| o |         | o |\                                                  C
9540 !     \ j|/k\|  /   \  |/k\|l /                                                C
9541 !      \ /   \ /     \ /   \ /                                                 C
9542 !       o     o       o     o                                                  C
9543 !       i             i                                                        C
9544 !                                                                              C
9545 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9546       itk=itortyp(itype(k,1))
9547       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9548       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9549       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9550       call transpose2(EUgC(1,1,k),auxmat(1,1))
9551       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9552       vv1(1)=pizda1(1,1)-pizda1(2,2)
9553       vv1(2)=pizda1(1,2)+pizda1(2,1)
9554       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9555       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9556       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9557       s5=scalar2(vv(1),Dtobr2(1,i))
9558 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9559       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9560       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9561        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9562        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9563        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9564        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9565        +scalar2(vv(1),Dtobr2der(1,i)))
9566       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9567       vv1(1)=pizda1(1,1)-pizda1(2,2)
9568       vv1(2)=pizda1(1,2)+pizda1(2,1)
9569       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9570       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9571       if (l.eq.j+1) then
9572         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9573        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9574        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9575        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9576        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9577       else
9578         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9579        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9580        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9581        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9582        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9583       endif
9584       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9585       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9586       vv1(1)=pizda1(1,1)-pizda1(2,2)
9587       vv1(2)=pizda1(1,2)+pizda1(2,1)
9588       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9589        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9590        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9591        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9592       do iii=1,2
9593         if (swap) then
9594           ind=3-iii
9595         else
9596           ind=iii
9597         endif
9598         do kkk=1,5
9599           do lll=1,3
9600             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9601             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9602             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9603             call transpose2(EUgC(1,1,k),auxmat(1,1))
9604             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9605               pizda1(1,1))
9606             vv1(1)=pizda1(1,1)-pizda1(2,2)
9607             vv1(2)=pizda1(1,2)+pizda1(2,1)
9608             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9609             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
9610              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9611             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
9612              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9613             s5=scalar2(vv(1),Dtobr2(1,i))
9614             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9615           enddo
9616         enddo
9617       enddo
9618       return
9619       end function eello6_graph1
9620 !-----------------------------------------------------------------------------
9621       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
9622       use comm_kut
9623 !      implicit real*8 (a-h,o-z)
9624 !      include 'DIMENSIONS'
9625 !      include 'COMMON.IOUNITS'
9626 !      include 'COMMON.CHAIN'
9627 !      include 'COMMON.DERIV'
9628 !      include 'COMMON.INTERACT'
9629 !      include 'COMMON.CONTACTS'
9630 !      include 'COMMON.TORSION'
9631 !      include 'COMMON.VAR'
9632 !      include 'COMMON.GEO'
9633       logical :: swap
9634       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
9635       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9636 !el      logical :: lprn
9637 !el      common /kutas/ lprn
9638       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
9639       real(kind=8) :: s2,s3,s4
9640 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9641 !                                                                              C
9642 !      Parallel       Antiparallel                                             C
9643 !                                                                              C
9644 !          o             o                                                     C
9645 !     \   /l\           /j\   /                                                C
9646 !      \ /   \         /   \ /                                                 C
9647 !       o| o |         | o |o                                                  C
9648 !     \ j|/k\|      \  |/k\|l                                                  C
9649 !      \ /   \       \ /   \                                                   C
9650 !       o             o                                                        C
9651 !       i             i                                                        C
9652 !                                                                              C
9653 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9654 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9655 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9656 !           but not in a cluster cumulant
9657 #ifdef MOMENT
9658       s1=dip(1,jj,i)*dip(1,kk,k)
9659 #endif
9660       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9661       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9662       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9663       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9664       call transpose2(EUg(1,1,k),auxmat(1,1))
9665       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9666       vv(1)=pizda(1,1)-pizda(2,2)
9667       vv(2)=pizda(1,2)+pizda(2,1)
9668       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9669 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9670 #ifdef MOMENT
9671       eello6_graph2=-(s1+s2+s3+s4)
9672 #else
9673       eello6_graph2=-(s2+s3+s4)
9674 #endif
9675 !      eello6_graph2=-s3
9676 ! Derivatives in gamma(i-1)
9677       if (i.gt.1) then
9678 #ifdef MOMENT
9679         s1=dipderg(1,jj,i)*dip(1,kk,k)
9680 #endif
9681         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9682         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9683         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9684         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9685 #ifdef MOMENT
9686         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9687 #else
9688         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9689 #endif
9690 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9691       endif
9692 ! Derivatives in gamma(k-1)
9693 #ifdef MOMENT
9694       s1=dip(1,jj,i)*dipderg(1,kk,k)
9695 #endif
9696       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9697       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9698       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9699       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9700       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9701       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9702       vv(1)=pizda(1,1)-pizda(2,2)
9703       vv(2)=pizda(1,2)+pizda(2,1)
9704       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9705 #ifdef MOMENT
9706       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9707 #else
9708       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9709 #endif
9710 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9711 ! Derivatives in gamma(j-1) or gamma(l-1)
9712       if (j.gt.1) then
9713 #ifdef MOMENT
9714         s1=dipderg(3,jj,i)*dip(1,kk,k)
9715 #endif
9716         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9717         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9718         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9719         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9720         vv(1)=pizda(1,1)-pizda(2,2)
9721         vv(2)=pizda(1,2)+pizda(2,1)
9722         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9723 #ifdef MOMENT
9724         if (swap) then
9725           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9726         else
9727           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9728         endif
9729 #endif
9730         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9731 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9732       endif
9733 ! Derivatives in gamma(l-1) or gamma(j-1)
9734       if (l.gt.1) then
9735 #ifdef MOMENT
9736         s1=dip(1,jj,i)*dipderg(3,kk,k)
9737 #endif
9738         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9739         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9740         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9741         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9742         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9743         vv(1)=pizda(1,1)-pizda(2,2)
9744         vv(2)=pizda(1,2)+pizda(2,1)
9745         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9746 #ifdef MOMENT
9747         if (swap) then
9748           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9749         else
9750           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9751         endif
9752 #endif
9753         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9754 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9755       endif
9756 ! Cartesian derivatives.
9757       if (lprn) then
9758         write (2,*) 'In eello6_graph2'
9759         do iii=1,2
9760           write (2,*) 'iii=',iii
9761           do kkk=1,5
9762             write (2,*) 'kkk=',kkk
9763             do jjj=1,2
9764               write (2,'(3(2f10.5),5x)') &
9765               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9766             enddo
9767           enddo
9768         enddo
9769       endif
9770       do iii=1,2
9771         do kkk=1,5
9772           do lll=1,3
9773 #ifdef MOMENT
9774             if (iii.eq.1) then
9775               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9776             else
9777               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9778             endif
9779 #endif
9780             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9781               auxvec(1))
9782             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9783             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9784               auxvec(1))
9785             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9786             call transpose2(EUg(1,1,k),auxmat(1,1))
9787             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9788               pizda(1,1))
9789             vv(1)=pizda(1,1)-pizda(2,2)
9790             vv(2)=pizda(1,2)+pizda(2,1)
9791             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9792 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9793 #ifdef MOMENT
9794             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9795 #else
9796             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9797 #endif
9798             if (swap) then
9799               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9800             else
9801               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9802             endif
9803           enddo
9804         enddo
9805       enddo
9806       return
9807       end function eello6_graph2
9808 !-----------------------------------------------------------------------------
9809       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9810 !      implicit real*8 (a-h,o-z)
9811 !      include 'DIMENSIONS'
9812 !      include 'COMMON.IOUNITS'
9813 !      include 'COMMON.CHAIN'
9814 !      include 'COMMON.DERIV'
9815 !      include 'COMMON.INTERACT'
9816 !      include 'COMMON.CONTACTS'
9817 !      include 'COMMON.TORSION'
9818 !      include 'COMMON.VAR'
9819 !      include 'COMMON.GEO'
9820       real(kind=8),dimension(2) :: vv,auxvec
9821       real(kind=8),dimension(2,2) :: pizda,auxmat
9822       logical :: swap
9823       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9824       real(kind=8) :: s1,s2,s3,s4
9825 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9826 !                                                                              C
9827 !      Parallel       Antiparallel                                             C
9828 !                                                                              C
9829 !          o             o                                                     C
9830 !         /l\   /   \   /j\                                                    C
9831 !        /   \ /     \ /   \                                                   C
9832 !       /| o |o       o| o |\                                                  C
9833 !       j|/k\|  /      |/k\|l /                                                C
9834 !        /   \ /       /   \ /                                                 C
9835 !       /     o       /     o                                                  C
9836 !       i             i                                                        C
9837 !                                                                              C
9838 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9839 !
9840 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9841 !           energy moment and not to the cluster cumulant.
9842       iti=itortyp(itype(i,1))
9843       if (j.lt.nres-1) then
9844         itj1=itortyp(itype(j+1,1))
9845       else
9846         itj1=ntortyp+1
9847       endif
9848       itk=itortyp(itype(k,1))
9849       itk1=itortyp(itype(k+1,1))
9850       if (l.lt.nres-1) then
9851         itl1=itortyp(itype(l+1,1))
9852       else
9853         itl1=ntortyp+1
9854       endif
9855 #ifdef MOMENT
9856       s1=dip(4,jj,i)*dip(4,kk,k)
9857 #endif
9858       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9859       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9860       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9861       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9862       call transpose2(EE(1,1,itk),auxmat(1,1))
9863       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9864       vv(1)=pizda(1,1)+pizda(2,2)
9865       vv(2)=pizda(2,1)-pizda(1,2)
9866       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9867 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9868 !d     & "sum",-(s2+s3+s4)
9869 #ifdef MOMENT
9870       eello6_graph3=-(s1+s2+s3+s4)
9871 #else
9872       eello6_graph3=-(s2+s3+s4)
9873 #endif
9874 !      eello6_graph3=-s4
9875 ! Derivatives in gamma(k-1)
9876       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9877       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9878       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9879       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9880 ! Derivatives in gamma(l-1)
9881       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9882       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9883       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9884       vv(1)=pizda(1,1)+pizda(2,2)
9885       vv(2)=pizda(2,1)-pizda(1,2)
9886       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9887       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9888 ! Cartesian derivatives.
9889       do iii=1,2
9890         do kkk=1,5
9891           do lll=1,3
9892 #ifdef MOMENT
9893             if (iii.eq.1) then
9894               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9895             else
9896               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9897             endif
9898 #endif
9899             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9900               auxvec(1))
9901             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9902             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9903               auxvec(1))
9904             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9905             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9906               pizda(1,1))
9907             vv(1)=pizda(1,1)+pizda(2,2)
9908             vv(2)=pizda(2,1)-pizda(1,2)
9909             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9910 #ifdef MOMENT
9911             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9912 #else
9913             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9914 #endif
9915             if (swap) then
9916               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9917             else
9918               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9919             endif
9920 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9921           enddo
9922         enddo
9923       enddo
9924       return
9925       end function eello6_graph3
9926 !-----------------------------------------------------------------------------
9927       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9928 !      implicit real*8 (a-h,o-z)
9929 !      include 'DIMENSIONS'
9930 !      include 'COMMON.IOUNITS'
9931 !      include 'COMMON.CHAIN'
9932 !      include 'COMMON.DERIV'
9933 !      include 'COMMON.INTERACT'
9934 !      include 'COMMON.CONTACTS'
9935 !      include 'COMMON.TORSION'
9936 !      include 'COMMON.VAR'
9937 !      include 'COMMON.GEO'
9938 !      include 'COMMON.FFIELD'
9939       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9940       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9941       logical :: swap
9942       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9943               iii,kkk,lll
9944       real(kind=8) :: s1,s2,s3,s4
9945 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9946 !                                                                              C
9947 !      Parallel       Antiparallel                                             C
9948 !                                                                              C
9949 !          o             o                                                     C
9950 !         /l\   /   \   /j\                                                    C
9951 !        /   \ /     \ /   \                                                   C
9952 !       /| o |o       o| o |\                                                  C
9953 !     \ j|/k\|      \  |/k\|l                                                  C
9954 !      \ /   \       \ /   \                                                   C
9955 !       o     \       o     \                                                  C
9956 !       i             i                                                        C
9957 !                                                                              C
9958 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9959 !
9960 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9961 !           energy moment and not to the cluster cumulant.
9962 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9963       iti=itortyp(itype(i,1))
9964       itj=itortyp(itype(j,1))
9965       if (j.lt.nres-1) then
9966         itj1=itortyp(itype(j+1,1))
9967       else
9968         itj1=ntortyp+1
9969       endif
9970       itk=itortyp(itype(k,1))
9971       if (k.lt.nres-1) then
9972         itk1=itortyp(itype(k+1,1))
9973       else
9974         itk1=ntortyp+1
9975       endif
9976       itl=itortyp(itype(l,1))
9977       if (l.lt.nres-1) then
9978         itl1=itortyp(itype(l+1,1))
9979       else
9980         itl1=ntortyp+1
9981       endif
9982 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9983 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9984 !d     & ' itl',itl,' itl1',itl1
9985 #ifdef MOMENT
9986       if (imat.eq.1) then
9987         s1=dip(3,jj,i)*dip(3,kk,k)
9988       else
9989         s1=dip(2,jj,j)*dip(2,kk,l)
9990       endif
9991 #endif
9992       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9993       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9994       if (j.eq.l+1) then
9995         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9996         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9997       else
9998         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9999         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10000       endif
10001       call transpose2(EUg(1,1,k),auxmat(1,1))
10002       call matmat2(AECA(1,1,imat),auxmat(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 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10007 #ifdef MOMENT
10008       eello6_graph4=-(s1+s2+s3+s4)
10009 #else
10010       eello6_graph4=-(s2+s3+s4)
10011 #endif
10012 ! Derivatives in gamma(i-1)
10013       if (i.gt.1) then
10014 #ifdef MOMENT
10015         if (imat.eq.1) then
10016           s1=dipderg(2,jj,i)*dip(3,kk,k)
10017         else
10018           s1=dipderg(4,jj,j)*dip(2,kk,l)
10019         endif
10020 #endif
10021         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10022         if (j.eq.l+1) then
10023           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
10024           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10025         else
10026           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
10027           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10028         endif
10029         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10030         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10031 !d          write (2,*) 'turn6 derivatives'
10032 #ifdef MOMENT
10033           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10034 #else
10035           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10036 #endif
10037         else
10038 #ifdef MOMENT
10039           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10040 #else
10041           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10042 #endif
10043         endif
10044       endif
10045 ! Derivatives in gamma(k-1)
10046 #ifdef MOMENT
10047       if (imat.eq.1) then
10048         s1=dip(3,jj,i)*dipderg(2,kk,k)
10049       else
10050         s1=dip(2,jj,j)*dipderg(4,kk,l)
10051       endif
10052 #endif
10053       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10054       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10055       if (j.eq.l+1) then
10056         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
10057         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
10058       else
10059         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
10060         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
10061       endif
10062       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10063       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10064       vv(1)=pizda(1,1)-pizda(2,2)
10065       vv(2)=pizda(2,1)+pizda(1,2)
10066       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10067       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10068 #ifdef MOMENT
10069         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10070 #else
10071         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10072 #endif
10073       else
10074 #ifdef MOMENT
10075         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10076 #else
10077         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10078 #endif
10079       endif
10080 ! Derivatives in gamma(j-1) or gamma(l-1)
10081       if (l.eq.j+1 .and. l.gt.1) then
10082         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10083         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10084         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10085         vv(1)=pizda(1,1)-pizda(2,2)
10086         vv(2)=pizda(2,1)+pizda(1,2)
10087         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10088         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10089       else if (j.gt.1) then
10090         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10091         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10092         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10093         vv(1)=pizda(1,1)-pizda(2,2)
10094         vv(2)=pizda(2,1)+pizda(1,2)
10095         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10096         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10097           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10098         else
10099           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10100         endif
10101       endif
10102 ! Cartesian derivatives.
10103       do iii=1,2
10104         do kkk=1,5
10105           do lll=1,3
10106 #ifdef MOMENT
10107             if (iii.eq.1) then
10108               if (imat.eq.1) then
10109                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10110               else
10111                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10112               endif
10113             else
10114               if (imat.eq.1) then
10115                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10116               else
10117                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10118               endif
10119             endif
10120 #endif
10121             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
10122               auxvec(1))
10123             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10124             if (j.eq.l+1) then
10125               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10126                 b1(1,itj1),auxvec(1))
10127               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
10128             else
10129               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
10130                 b1(1,itl1),auxvec(1))
10131               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
10132             endif
10133             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
10134               pizda(1,1))
10135             vv(1)=pizda(1,1)-pizda(2,2)
10136             vv(2)=pizda(2,1)+pizda(1,2)
10137             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10138             if (swap) then
10139               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10140 #ifdef MOMENT
10141                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10142                    -(s1+s2+s4)
10143 #else
10144                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
10145                    -(s2+s4)
10146 #endif
10147                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10148               else
10149 #ifdef MOMENT
10150                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10151 #else
10152                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10153 #endif
10154                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10155               endif
10156             else
10157 #ifdef MOMENT
10158               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10159 #else
10160               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10161 #endif
10162               if (l.eq.j+1) then
10163                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10164               else
10165                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10166               endif
10167             endif
10168           enddo
10169         enddo
10170       enddo
10171       return
10172       end function eello6_graph4
10173 !-----------------------------------------------------------------------------
10174       real(kind=8) function eello_turn6(i,jj,kk)
10175 !      implicit real*8 (a-h,o-z)
10176 !      include 'DIMENSIONS'
10177 !      include 'COMMON.IOUNITS'
10178 !      include 'COMMON.CHAIN'
10179 !      include 'COMMON.DERIV'
10180 !      include 'COMMON.INTERACT'
10181 !      include 'COMMON.CONTACTS'
10182 !      include 'COMMON.TORSION'
10183 !      include 'COMMON.VAR'
10184 !      include 'COMMON.GEO'
10185       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
10186       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
10187       real(kind=8),dimension(3) :: ggg1,ggg2
10188       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
10189       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
10190 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10191 !           the respective energy moment and not to the cluster cumulant.
10192 !el local variables
10193       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
10194       integer :: j1,j2,l1,l2,ll
10195       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
10196       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
10197       s1=0.0d0
10198       s8=0.0d0
10199       s13=0.0d0
10200 !
10201       eello_turn6=0.0d0
10202       j=i+4
10203       k=i+1
10204       l=i+3
10205       iti=itortyp(itype(i,1))
10206       itk=itortyp(itype(k,1))
10207       itk1=itortyp(itype(k+1,1))
10208       itl=itortyp(itype(l,1))
10209       itj=itortyp(itype(j,1))
10210 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10211 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
10212 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10213 !d        eello6=0.0d0
10214 !d        return
10215 !d      endif
10216 !d      write (iout,*)
10217 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10218 !d     &   ' and',k,l
10219 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
10220       do iii=1,2
10221         do kkk=1,5
10222           do lll=1,3
10223             derx_turn(lll,kkk,iii)=0.0d0
10224           enddo
10225         enddo
10226       enddo
10227 !d      eij=1.0d0
10228 !d      ekl=1.0d0
10229 !d      ekont=1.0d0
10230       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10231 !d      eello6_5=0.0d0
10232 !d      write (2,*) 'eello6_5',eello6_5
10233 #ifdef MOMENT
10234       call transpose2(AEA(1,1,1),auxmat(1,1))
10235       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10236       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10237       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10238 #endif
10239       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10240       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10241       s2 = scalar2(b1(1,itk),vtemp1(1))
10242 #ifdef MOMENT
10243       call transpose2(AEA(1,1,2),atemp(1,1))
10244       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10245       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10246       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10247 #endif
10248       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10249       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10250       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10251 #ifdef MOMENT
10252       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10253       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10254       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10255       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10256       ss13 = scalar2(b1(1,itk),vtemp4(1))
10257       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10258 #endif
10259 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10260 !      s1=0.0d0
10261 !      s2=0.0d0
10262 !      s8=0.0d0
10263 !      s12=0.0d0
10264 !      s13=0.0d0
10265       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10266 ! Derivatives in gamma(i+2)
10267       s1d =0.0d0
10268       s8d =0.0d0
10269 #ifdef MOMENT
10270       call transpose2(AEA(1,1,1),auxmatd(1,1))
10271       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10272       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10273       call transpose2(AEAderg(1,1,2),atempd(1,1))
10274       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10275       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10276 #endif
10277       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10278       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10279       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10280 !      s1d=0.0d0
10281 !      s2d=0.0d0
10282 !      s8d=0.0d0
10283 !      s12d=0.0d0
10284 !      s13d=0.0d0
10285       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10286 ! Derivatives in gamma(i+3)
10287 #ifdef MOMENT
10288       call transpose2(AEA(1,1,1),auxmatd(1,1))
10289       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10290       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10291       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10292 #endif
10293       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10294       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10295       s2d = scalar2(b1(1,itk),vtemp1d(1))
10296 #ifdef MOMENT
10297       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10298       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10299 #endif
10300       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10301 #ifdef MOMENT
10302       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10303       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10304       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10305 #endif
10306 !      s1d=0.0d0
10307 !      s2d=0.0d0
10308 !      s8d=0.0d0
10309 !      s12d=0.0d0
10310 !      s13d=0.0d0
10311 #ifdef MOMENT
10312       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10313                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10314 #else
10315       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10316                     -0.5d0*ekont*(s2d+s12d)
10317 #endif
10318 ! Derivatives in gamma(i+4)
10319       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10320       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10321       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10322 #ifdef MOMENT
10323       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10324       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10325       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10326 #endif
10327 !      s1d=0.0d0
10328 !      s2d=0.0d0
10329 !      s8d=0.0d0
10330 !      s12d=0.0d0
10331 !      s13d=0.0d0
10332 #ifdef MOMENT
10333       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10334 #else
10335       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10336 #endif
10337 ! Derivatives in gamma(i+5)
10338 #ifdef MOMENT
10339       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10340       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10341       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10342 #endif
10343       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10344       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10345       s2d = scalar2(b1(1,itk),vtemp1d(1))
10346 #ifdef MOMENT
10347       call transpose2(AEA(1,1,2),atempd(1,1))
10348       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10349       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10350 #endif
10351       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10352       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10353 #ifdef MOMENT
10354       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10355       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10356       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10357 #endif
10358 !      s1d=0.0d0
10359 !      s2d=0.0d0
10360 !      s8d=0.0d0
10361 !      s12d=0.0d0
10362 !      s13d=0.0d0
10363 #ifdef MOMENT
10364       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10365                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10366 #else
10367       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10368                     -0.5d0*ekont*(s2d+s12d)
10369 #endif
10370 ! Cartesian derivatives
10371       do iii=1,2
10372         do kkk=1,5
10373           do lll=1,3
10374 #ifdef MOMENT
10375             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10376             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10377             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10378 #endif
10379             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10380             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10381                 vtemp1d(1))
10382             s2d = scalar2(b1(1,itk),vtemp1d(1))
10383 #ifdef MOMENT
10384             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10385             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10386             s8d = -(atempd(1,1)+atempd(2,2))* &
10387                  scalar2(cc(1,1,itl),vtemp2(1))
10388 #endif
10389             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10390                  auxmatd(1,1))
10391             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10392             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10393 !      s1d=0.0d0
10394 !      s2d=0.0d0
10395 !      s8d=0.0d0
10396 !      s12d=0.0d0
10397 !      s13d=0.0d0
10398 #ifdef MOMENT
10399             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10400               - 0.5d0*(s1d+s2d)
10401 #else
10402             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10403               - 0.5d0*s2d
10404 #endif
10405 #ifdef MOMENT
10406             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10407               - 0.5d0*(s8d+s12d)
10408 #else
10409             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10410               - 0.5d0*s12d
10411 #endif
10412           enddo
10413         enddo
10414       enddo
10415 #ifdef MOMENT
10416       do kkk=1,5
10417         do lll=1,3
10418           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10419             achuj_tempd(1,1))
10420           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10421           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10422           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10423           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10424           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10425             vtemp4d(1))
10426           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10427           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10428           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10429         enddo
10430       enddo
10431 #endif
10432 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10433 !d     &  16*eel_turn6_num
10434 !d      goto 1112
10435       if (j.lt.nres-1) then
10436         j1=j+1
10437         j2=j-1
10438       else
10439         j1=j-1
10440         j2=j-2
10441       endif
10442       if (l.lt.nres-1) then
10443         l1=l+1
10444         l2=l-1
10445       else
10446         l1=l-1
10447         l2=l-2
10448       endif
10449       do ll=1,3
10450 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10451 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10452 !grad        ghalf=0.5d0*ggg1(ll)
10453 !d        ghalf=0.0d0
10454         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10455         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10456         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10457           +ekont*derx_turn(ll,2,1)
10458         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10459         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10460           +ekont*derx_turn(ll,4,1)
10461         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10462         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10463         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10464 !grad        ghalf=0.5d0*ggg2(ll)
10465 !d        ghalf=0.0d0
10466         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10467           +ekont*derx_turn(ll,2,2)
10468         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10469         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10470           +ekont*derx_turn(ll,4,2)
10471         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10472         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10473         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10474       enddo
10475 !d      goto 1112
10476 !grad      do m=i+1,j-1
10477 !grad        do ll=1,3
10478 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10479 !grad        enddo
10480 !grad      enddo
10481 !grad      do m=k+1,l-1
10482 !grad        do ll=1,3
10483 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10484 !grad        enddo
10485 !grad      enddo
10486 !grad1112  continue
10487 !grad      do m=i+2,j2
10488 !grad        do ll=1,3
10489 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10490 !grad        enddo
10491 !grad      enddo
10492 !grad      do m=k+2,l2
10493 !grad        do ll=1,3
10494 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10495 !grad        enddo
10496 !grad      enddo
10497 !d      do iii=1,nres-3
10498 !d        write (2,*) iii,g_corr6_loc(iii)
10499 !d      enddo
10500       eello_turn6=ekont*eel_turn6
10501 !d      write (2,*) 'ekont',ekont
10502 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10503       return
10504       end function eello_turn6
10505 !-----------------------------------------------------------------------------
10506       subroutine MATVEC2(A1,V1,V2)
10507 !DIR$ INLINEALWAYS MATVEC2
10508 #ifndef OSF
10509 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10510 #endif
10511 !      implicit real*8 (a-h,o-z)
10512 !      include 'DIMENSIONS'
10513       real(kind=8),dimension(2) :: V1,V2
10514       real(kind=8),dimension(2,2) :: A1
10515       real(kind=8) :: vaux1,vaux2
10516 !      DO 1 I=1,2
10517 !        VI=0.0
10518 !        DO 3 K=1,2
10519 !    3     VI=VI+A1(I,K)*V1(K)
10520 !        Vaux(I)=VI
10521 !    1 CONTINUE
10522
10523       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10524       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10525
10526       v2(1)=vaux1
10527       v2(2)=vaux2
10528       end subroutine MATVEC2
10529 !-----------------------------------------------------------------------------
10530       subroutine MATMAT2(A1,A2,A3)
10531 #ifndef OSF
10532 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10533 #endif
10534 !      implicit real*8 (a-h,o-z)
10535 !      include 'DIMENSIONS'
10536       real(kind=8),dimension(2,2) :: A1,A2,A3
10537       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10538 !      DIMENSION AI3(2,2)
10539 !        DO  J=1,2
10540 !          A3IJ=0.0
10541 !          DO K=1,2
10542 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10543 !          enddo
10544 !          A3(I,J)=A3IJ
10545 !       enddo
10546 !      enddo
10547
10548       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10549       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10550       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10551       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10552
10553       A3(1,1)=AI3_11
10554       A3(2,1)=AI3_21
10555       A3(1,2)=AI3_12
10556       A3(2,2)=AI3_22
10557       end subroutine MATMAT2
10558 !-----------------------------------------------------------------------------
10559       real(kind=8) function scalar2(u,v)
10560 !DIR$ INLINEALWAYS scalar2
10561       implicit none
10562       real(kind=8),dimension(2) :: u,v
10563       real(kind=8) :: sc
10564       integer :: i
10565       scalar2=u(1)*v(1)+u(2)*v(2)
10566       return
10567       end function scalar2
10568 !-----------------------------------------------------------------------------
10569       subroutine transpose2(a,at)
10570 !DIR$ INLINEALWAYS transpose2
10571 #ifndef OSF
10572 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10573 #endif
10574       implicit none
10575       real(kind=8),dimension(2,2) :: a,at
10576       at(1,1)=a(1,1)
10577       at(1,2)=a(2,1)
10578       at(2,1)=a(1,2)
10579       at(2,2)=a(2,2)
10580       return
10581       end subroutine transpose2
10582 !-----------------------------------------------------------------------------
10583       subroutine transpose(n,a,at)
10584       implicit none
10585       integer :: n,i,j
10586       real(kind=8),dimension(n,n) :: a,at
10587       do i=1,n
10588         do j=1,n
10589           at(j,i)=a(i,j)
10590         enddo
10591       enddo
10592       return
10593       end subroutine transpose
10594 !-----------------------------------------------------------------------------
10595       subroutine prodmat3(a1,a2,kk,transp,prod)
10596 !DIR$ INLINEALWAYS prodmat3
10597 #ifndef OSF
10598 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10599 #endif
10600       implicit none
10601       integer :: i,j
10602       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10603       logical :: transp
10604 !rc      double precision auxmat(2,2),prod_(2,2)
10605
10606       if (transp) then
10607 !rc        call transpose2(kk(1,1),auxmat(1,1))
10608 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10609 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10610
10611            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
10612        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10613            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
10614        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10615            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
10616        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10617            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10618        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10619
10620       else
10621 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10622 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10623
10624            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
10625         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10626            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
10627         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10628            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
10629         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10630            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
10631         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10632
10633       endif
10634 !      call transpose2(a2(1,1),a2t(1,1))
10635
10636 !rc      print *,transp
10637 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
10638 !rc      print *,((prod(i,j),i=1,2),j=1,2)
10639
10640       return
10641       end subroutine prodmat3
10642 !-----------------------------------------------------------------------------
10643 ! energy_p_new_barrier.F
10644 !-----------------------------------------------------------------------------
10645       subroutine sum_gradient
10646 !      implicit real*8 (a-h,o-z)
10647       use io_base, only: pdbout
10648 !      include 'DIMENSIONS'
10649 #ifndef ISNAN
10650       external proc_proc
10651 #ifdef WINPGI
10652 !MS$ATTRIBUTES C ::  proc_proc
10653 #endif
10654 #endif
10655 #ifdef MPI
10656       include 'mpif.h'
10657 #endif
10658       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10659                    gloc_scbuf !(3,maxres)
10660
10661       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10662 !#endif
10663 !el local variables
10664       integer :: i,j,k,ierror,ierr
10665       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10666                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10667                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10668                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10669                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10670                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10671                    gsccorr_max,gsccorrx_max,time00
10672
10673 !      include 'COMMON.SETUP'
10674 !      include 'COMMON.IOUNITS'
10675 !      include 'COMMON.FFIELD'
10676 !      include 'COMMON.DERIV'
10677 !      include 'COMMON.INTERACT'
10678 !      include 'COMMON.SBRIDGE'
10679 !      include 'COMMON.CHAIN'
10680 !      include 'COMMON.VAR'
10681 !      include 'COMMON.CONTROL'
10682 !      include 'COMMON.TIME1'
10683 !      include 'COMMON.MAXGRAD'
10684 !      include 'COMMON.SCCOR'
10685 #ifdef TIMING
10686       time01=MPI_Wtime()
10687 #endif
10688 #ifdef DEBUG
10689       write (iout,*) "sum_gradient gvdwc, gvdwx"
10690       do i=1,nres
10691         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10692          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10693       enddo
10694       call flush(iout)
10695 #endif
10696 #ifdef MPI
10697         gradbufc=0.0d0
10698         gradbufx=0.0d0
10699         gradbufc_sum=0.0d0
10700         gloc_scbuf=0.0d0
10701         glocbuf=0.0d0
10702 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10703         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10704           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10705 #endif
10706 !
10707 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10708 !            in virtual-bond-vector coordinates
10709 !
10710 #ifdef DEBUG
10711 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10712 !      do i=1,nres-1
10713 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10714 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10715 !      enddo
10716 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10717 !      do i=1,nres-1
10718 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10719 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10720 !      enddo
10721       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10722       do i=1,nres
10723         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10724          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10725          (gvdwc_scpp(j,i),j=1,3)
10726       enddo
10727       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10728       do i=1,nres
10729         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10730          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10731          (gelc_loc_long(j,i),j=1,3)
10732       enddo
10733       call flush(iout)
10734 #endif
10735 #ifdef SPLITELE
10736       do i=0,nct
10737         do j=1,3
10738           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10739                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10740                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10741                       wel_loc*gel_loc_long(j,i)+ &
10742                       wcorr*gradcorr_long(j,i)+ &
10743                       wcorr5*gradcorr5_long(j,i)+ &
10744                       wcorr6*gradcorr6_long(j,i)+ &
10745                       wturn6*gcorr6_turn_long(j,i)+ &
10746                       wstrain*ghpbc(j,i) &
10747                      +wliptran*gliptranc(j,i) &
10748                      +gradafm(j,i) &
10749                      +welec*gshieldc(j,i) &
10750                      +wcorr*gshieldc_ec(j,i) &
10751                      +wturn3*gshieldc_t3(j,i)&
10752                      +wturn4*gshieldc_t4(j,i)&
10753                      +wel_loc*gshieldc_ll(j,i)&
10754                      +wtube*gg_tube(j,i) &
10755                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10756                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10757                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10758                      wcorr_nucl*gradcorr_nucl(j,i)&
10759                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
10760                      wcatprot* gradpepcat(j,i)+ &
10761                      wcatcat*gradcatcat(j,i)+   &
10762                      wscbase*gvdwc_scbase(j,i)+ &
10763                      wpepbase*gvdwc_pepbase(j,i)+&
10764                      wscpho*gvdwc_scpho(j,i)+   &
10765                      wpeppho*gvdwc_peppho(j,i)
10766
10767
10768
10769
10770
10771         enddo
10772       enddo
10773 #else
10774       do i=0,nct
10775         do j=1,3
10776           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10777                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10778                       welec*gelc_long(j,i)+ &
10779                       wbond*gradb(j,i)+ &
10780                       wel_loc*gel_loc_long(j,i)+ &
10781                       wcorr*gradcorr_long(j,i)+ &
10782                       wcorr5*gradcorr5_long(j,i)+ &
10783                       wcorr6*gradcorr6_long(j,i)+ &
10784                       wturn6*gcorr6_turn_long(j,i)+ &
10785                       wstrain*ghpbc(j,i) &
10786                      +wliptran*gliptranc(j,i) &
10787                      +gradafm(j,i) &
10788                      +welec*gshieldc(j,i)&
10789                      +wcorr*gshieldc_ec(j,i) &
10790                      +wturn4*gshieldc_t4(j,i) &
10791                      +wel_loc*gshieldc_ll(j,i)&
10792                      +wtube*gg_tube(j,i) &
10793                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10794                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10795                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10796                      wcorr_nucl*gradcorr_nucl(j,i) &
10797                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
10798                      wcatprot* gradpepcat(j,i)+ &
10799                      wcatcat*gradcatcat(j,i)+   &
10800                      wscbase*gvdwc_scbase(j,i)  &
10801                      wpepbase*gvdwc_pepbase(j,i)+&
10802                      wscpho*gvdwc_scpho(j,i)+&
10803                      wpeppho*gvdwc_peppho(j,i)
10804
10805
10806         enddo
10807       enddo
10808 #endif
10809 #ifdef MPI
10810       if (nfgtasks.gt.1) then
10811       time00=MPI_Wtime()
10812 #ifdef DEBUG
10813       write (iout,*) "gradbufc before allreduce"
10814       do i=1,nres
10815         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10816       enddo
10817       call flush(iout)
10818 #endif
10819       do i=0,nres
10820         do j=1,3
10821           gradbufc_sum(j,i)=gradbufc(j,i)
10822         enddo
10823       enddo
10824 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10825 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10826 !      time_reduce=time_reduce+MPI_Wtime()-time00
10827 #ifdef DEBUG
10828 !      write (iout,*) "gradbufc_sum after allreduce"
10829 !      do i=1,nres
10830 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10831 !      enddo
10832 !      call flush(iout)
10833 #endif
10834 #ifdef TIMING
10835 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10836 #endif
10837       do i=0,nres
10838         do k=1,3
10839           gradbufc(k,i)=0.0d0
10840         enddo
10841       enddo
10842 #ifdef DEBUG
10843       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10844       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10845                         " jgrad_end  ",jgrad_end(i),&
10846                         i=igrad_start,igrad_end)
10847 #endif
10848 !
10849 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10850 ! do not parallelize this part.
10851 !
10852 !      do i=igrad_start,igrad_end
10853 !        do j=jgrad_start(i),jgrad_end(i)
10854 !          do k=1,3
10855 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10856 !          enddo
10857 !        enddo
10858 !      enddo
10859       do j=1,3
10860         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10861       enddo
10862       do i=nres-2,-1,-1
10863         do j=1,3
10864           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10865         enddo
10866       enddo
10867 #ifdef DEBUG
10868       write (iout,*) "gradbufc after summing"
10869       do i=1,nres
10870         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10871       enddo
10872       call flush(iout)
10873 #endif
10874       else
10875 #endif
10876 !el#define DEBUG
10877 #ifdef DEBUG
10878       write (iout,*) "gradbufc"
10879       do i=1,nres
10880         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10881       enddo
10882       call flush(iout)
10883 #endif
10884 !el#undef DEBUG
10885       do i=-1,nres
10886         do j=1,3
10887           gradbufc_sum(j,i)=gradbufc(j,i)
10888           gradbufc(j,i)=0.0d0
10889         enddo
10890       enddo
10891       do j=1,3
10892         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10893       enddo
10894       do i=nres-2,-1,-1
10895         do j=1,3
10896           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10897         enddo
10898       enddo
10899 !      do i=nnt,nres-1
10900 !        do k=1,3
10901 !          gradbufc(k,i)=0.0d0
10902 !        enddo
10903 !        do j=i+1,nres
10904 !          do k=1,3
10905 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10906 !          enddo
10907 !        enddo
10908 !      enddo
10909 !el#define DEBUG
10910 #ifdef DEBUG
10911       write (iout,*) "gradbufc after summing"
10912       do i=1,nres
10913         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10914       enddo
10915       call flush(iout)
10916 #endif
10917 !el#undef DEBUG
10918 #ifdef MPI
10919       endif
10920 #endif
10921       do k=1,3
10922         gradbufc(k,nres)=0.0d0
10923       enddo
10924 !el----------------
10925 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10926 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10927 !el-----------------
10928       do i=-1,nct
10929         do j=1,3
10930 #ifdef SPLITELE
10931           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10932                       wel_loc*gel_loc(j,i)+ &
10933                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10934                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10935                       wel_loc*gel_loc_long(j,i)+ &
10936                       wcorr*gradcorr_long(j,i)+ &
10937                       wcorr5*gradcorr5_long(j,i)+ &
10938                       wcorr6*gradcorr6_long(j,i)+ &
10939                       wturn6*gcorr6_turn_long(j,i))+ &
10940                       wbond*gradb(j,i)+ &
10941                       wcorr*gradcorr(j,i)+ &
10942                       wturn3*gcorr3_turn(j,i)+ &
10943                       wturn4*gcorr4_turn(j,i)+ &
10944                       wcorr5*gradcorr5(j,i)+ &
10945                       wcorr6*gradcorr6(j,i)+ &
10946                       wturn6*gcorr6_turn(j,i)+ &
10947                       wsccor*gsccorc(j,i) &
10948                      +wscloc*gscloc(j,i)  &
10949                      +wliptran*gliptranc(j,i) &
10950                      +gradafm(j,i) &
10951                      +welec*gshieldc(j,i) &
10952                      +welec*gshieldc_loc(j,i) &
10953                      +wcorr*gshieldc_ec(j,i) &
10954                      +wcorr*gshieldc_loc_ec(j,i) &
10955                      +wturn3*gshieldc_t3(j,i) &
10956                      +wturn3*gshieldc_loc_t3(j,i) &
10957                      +wturn4*gshieldc_t4(j,i) &
10958                      +wturn4*gshieldc_loc_t4(j,i) &
10959                      +wel_loc*gshieldc_ll(j,i) &
10960                      +wel_loc*gshieldc_loc_ll(j,i) &
10961                      +wtube*gg_tube(j,i) &
10962                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10963                      +wvdwpsb*gvdwpsb1(j,i))&
10964                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
10965 !                      if (i.eq.21) then
10966 !                      print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),&
10967 !                      wturn4*gshieldc_t4(j,i), &
10968 !                     wturn4*gshieldc_loc_t4(j,i)
10969 !                       endif
10970 !                 if ((i.le.2).and.(i.ge.1))
10971 !                       print *,gradc(j,i,icg),&
10972 !                      gradbufc(j,i),welec*gelc(j,i), &
10973 !                      wel_loc*gel_loc(j,i), &
10974 !                      wscp*gvdwc_scpp(j,i), &
10975 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
10976 !                      wel_loc*gel_loc_long(j,i), &
10977 !                      wcorr*gradcorr_long(j,i), &
10978 !                      wcorr5*gradcorr5_long(j,i), &
10979 !                      wcorr6*gradcorr6_long(j,i), &
10980 !                      wturn6*gcorr6_turn_long(j,i), &
10981 !                      wbond*gradb(j,i), &
10982 !                      wcorr*gradcorr(j,i), &
10983 !                      wturn3*gcorr3_turn(j,i), &
10984 !                      wturn4*gcorr4_turn(j,i), &
10985 !                      wcorr5*gradcorr5(j,i), &
10986 !                      wcorr6*gradcorr6(j,i), &
10987 !                      wturn6*gcorr6_turn(j,i), &
10988 !                      wsccor*gsccorc(j,i) &
10989 !                     ,wscloc*gscloc(j,i)  &
10990 !                     ,wliptran*gliptranc(j,i) &
10991 !                    ,gradafm(j,i) &
10992 !                     ,welec*gshieldc(j,i) &
10993 !                     ,welec*gshieldc_loc(j,i) &
10994 !                     ,wcorr*gshieldc_ec(j,i) &
10995 !                     ,wcorr*gshieldc_loc_ec(j,i) &
10996 !                     ,wturn3*gshieldc_t3(j,i) &
10997 !                     ,wturn3*gshieldc_loc_t3(j,i) &
10998 !                     ,wturn4*gshieldc_t4(j,i) &
10999 !                     ,wturn4*gshieldc_loc_t4(j,i) &
11000 !                     ,wel_loc*gshieldc_ll(j,i) &
11001 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
11002 !                     ,wtube*gg_tube(j,i) &
11003 !                     ,wbond_nucl*gradb_nucl(j,i) &
11004 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
11005 !                     wvdwpsb*gvdwpsb1(j,i)&
11006 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
11007 !
11008
11009 #else
11010           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
11011                       wel_loc*gel_loc(j,i)+ &
11012                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
11013                       welec*gelc_long(j,i)+ &
11014                       wel_loc*gel_loc_long(j,i)+ &
11015 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
11016                       wcorr5*gradcorr5_long(j,i)+ &
11017                       wcorr6*gradcorr6_long(j,i)+ &
11018                       wturn6*gcorr6_turn_long(j,i))+ &
11019                       wbond*gradb(j,i)+ &
11020                       wcorr*gradcorr(j,i)+ &
11021                       wturn3*gcorr3_turn(j,i)+ &
11022                       wturn4*gcorr4_turn(j,i)+ &
11023                       wcorr5*gradcorr5(j,i)+ &
11024                       wcorr6*gradcorr6(j,i)+ &
11025                       wturn6*gcorr6_turn(j,i)+ &
11026                       wsccor*gsccorc(j,i) &
11027                      +wscloc*gscloc(j,i) &
11028                      +gradafm(j,i) &
11029                      +wliptran*gliptranc(j,i) &
11030                      +welec*gshieldc(j,i) &
11031                      +welec*gshieldc_loc(j,) &
11032                      +wcorr*gshieldc_ec(j,i) &
11033                      +wcorr*gshieldc_loc_ec(j,i) &
11034                      +wturn3*gshieldc_t3(j,i) &
11035                      +wturn3*gshieldc_loc_t3(j,i) &
11036                      +wturn4*gshieldc_t4(j,i) &
11037                      +wturn4*gshieldc_loc_t4(j,i) &
11038                      +wel_loc*gshieldc_ll(j,i) &
11039                      +wel_loc*gshieldc_loc_ll(j,i) &
11040                      +wtube*gg_tube(j,i) &
11041                      +wbond_nucl*gradb_nucl(j,i) &
11042                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
11043                      +wvdwpsb*gvdwpsb1(j,i))&
11044                      +wsbloc*gsbloc(j,i)
11045
11046
11047
11048
11049 #endif
11050           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
11051                         wbond*gradbx(j,i)+ &
11052                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
11053                         wsccor*gsccorx(j,i) &
11054                        +wscloc*gsclocx(j,i) &
11055                        +wliptran*gliptranx(j,i) &
11056                        +welec*gshieldx(j,i)     &
11057                        +wcorr*gshieldx_ec(j,i)  &
11058                        +wturn3*gshieldx_t3(j,i) &
11059                        +wturn4*gshieldx_t4(j,i) &
11060                        +wel_loc*gshieldx_ll(j,i)&
11061                        +wtube*gg_tube_sc(j,i)   &
11062                        +wbond_nucl*gradbx_nucl(j,i) &
11063                        +wvdwsb*gvdwsbx(j,i) &
11064                        +welsb*gelsbx(j,i) &
11065                        +wcorr_nucl*gradxorr_nucl(j,i)&
11066                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
11067                        +wsbloc*gsblocx(j,i) &
11068                        +wcatprot* gradpepcatx(j,i)&
11069                        +wscbase*gvdwx_scbase(j,i) &
11070                        +wpepbase*gvdwx_pepbase(j,i)&
11071                        +wscpho*gvdwx_scpho(j,i)
11072 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
11073
11074         enddo
11075       enddo
11076 !#define DEBUG
11077 #ifdef DEBUG
11078       write (iout,*) "gloc before adding corr"
11079       do i=1,4*nres
11080         write (iout,*) i,gloc(i,icg)
11081       enddo
11082 #endif
11083       do i=1,nres-3
11084         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
11085          +wcorr5*g_corr5_loc(i) &
11086          +wcorr6*g_corr6_loc(i) &
11087          +wturn4*gel_loc_turn4(i) &
11088          +wturn3*gel_loc_turn3(i) &
11089          +wturn6*gel_loc_turn6(i) &
11090          +wel_loc*gel_loc_loc(i)
11091       enddo
11092 #ifdef DEBUG
11093       write (iout,*) "gloc after adding corr"
11094       do i=1,4*nres
11095         write (iout,*) i,gloc(i,icg)
11096       enddo
11097 #endif
11098 !#undef DEBUG
11099 #ifdef MPI
11100       if (nfgtasks.gt.1) then
11101         do j=1,3
11102           do i=0,nres
11103             gradbufc(j,i)=gradc(j,i,icg)
11104             gradbufx(j,i)=gradx(j,i,icg)
11105           enddo
11106         enddo
11107         do i=1,4*nres
11108           glocbuf(i)=gloc(i,icg)
11109         enddo
11110 !#define DEBUG
11111 #ifdef DEBUG
11112       write (iout,*) "gloc_sc before reduce"
11113       do i=1,nres
11114        do j=1,1
11115         write (iout,*) i,j,gloc_sc(j,i,icg)
11116        enddo
11117       enddo
11118 #endif
11119 !#undef DEBUG
11120         do i=1,nres
11121          do j=1,3
11122           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
11123          enddo
11124         enddo
11125         time00=MPI_Wtime()
11126         call MPI_Barrier(FG_COMM,IERR)
11127         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
11128         time00=MPI_Wtime()
11129         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
11130           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11131         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
11132           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11133         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
11134           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11135         time_reduce=time_reduce+MPI_Wtime()-time00
11136         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
11137           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
11138         time_reduce=time_reduce+MPI_Wtime()-time00
11139 !#define DEBUG
11140 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
11141 #ifdef DEBUG
11142       write (iout,*) "gloc_sc after reduce"
11143       do i=1,nres
11144        do j=1,1
11145         write (iout,*) i,j,gloc_sc(j,i,icg)
11146        enddo
11147       enddo
11148 #endif
11149 !#undef DEBUG
11150 #ifdef DEBUG
11151       write (iout,*) "gloc after reduce"
11152       do i=1,4*nres
11153         write (iout,*) i,gloc(i,icg)
11154       enddo
11155 #endif
11156       endif
11157 #endif
11158       if (gnorm_check) then
11159 !
11160 ! Compute the maximum elements of the gradient
11161 !
11162       gvdwc_max=0.0d0
11163       gvdwc_scp_max=0.0d0
11164       gelc_max=0.0d0
11165       gvdwpp_max=0.0d0
11166       gradb_max=0.0d0
11167       ghpbc_max=0.0d0
11168       gradcorr_max=0.0d0
11169       gel_loc_max=0.0d0
11170       gcorr3_turn_max=0.0d0
11171       gcorr4_turn_max=0.0d0
11172       gradcorr5_max=0.0d0
11173       gradcorr6_max=0.0d0
11174       gcorr6_turn_max=0.0d0
11175       gsccorc_max=0.0d0
11176       gscloc_max=0.0d0
11177       gvdwx_max=0.0d0
11178       gradx_scp_max=0.0d0
11179       ghpbx_max=0.0d0
11180       gradxorr_max=0.0d0
11181       gsccorx_max=0.0d0
11182       gsclocx_max=0.0d0
11183       do i=1,nct
11184         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
11185         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
11186         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
11187         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
11188          gvdwc_scp_max=gvdwc_scp_norm
11189         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
11190         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
11191         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
11192         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
11193         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
11194         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
11195         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
11196         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
11197         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
11198         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
11199         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
11200         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
11201         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
11202           gcorr3_turn(1,i)))
11203         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
11204           gcorr3_turn_max=gcorr3_turn_norm
11205         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
11206           gcorr4_turn(1,i)))
11207         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
11208           gcorr4_turn_max=gcorr4_turn_norm
11209         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
11210         if (gradcorr5_norm.gt.gradcorr5_max) &
11211           gradcorr5_max=gradcorr5_norm
11212         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
11213         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
11214         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
11215           gcorr6_turn(1,i)))
11216         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
11217           gcorr6_turn_max=gcorr6_turn_norm
11218         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
11219         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
11220         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
11221         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
11222         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
11223         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
11224         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
11225         if (gradx_scp_norm.gt.gradx_scp_max) &
11226           gradx_scp_max=gradx_scp_norm
11227         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
11228         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
11229         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
11230         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
11231         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
11232         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
11233         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
11234         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11235       enddo
11236       if (gradout) then
11237 #ifdef AIX
11238         open(istat,file=statname,position="append")
11239 #else
11240         open(istat,file=statname,access="append")
11241 #endif
11242         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11243            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11244            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11245            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11246            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11247            gsccorx_max,gsclocx_max
11248         close(istat)
11249         if (gvdwc_max.gt.1.0d4) then
11250           write (iout,*) "gvdwc gvdwx gradb gradbx"
11251           do i=nnt,nct
11252             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11253               gradb(j,i),gradbx(j,i),j=1,3)
11254           enddo
11255           call pdbout(0.0d0,'cipiszcze',iout)
11256           call flush(iout)
11257         endif
11258       endif
11259       endif
11260 !#define DEBUG
11261 #ifdef DEBUG
11262       write (iout,*) "gradc gradx gloc"
11263       do i=1,nres
11264         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11265          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11266       enddo
11267 #endif
11268 !#undef DEBUG
11269 #ifdef TIMING
11270       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11271 #endif
11272       return
11273       end subroutine sum_gradient
11274 !-----------------------------------------------------------------------------
11275       subroutine sc_grad
11276 !      implicit real*8 (a-h,o-z)
11277       use calc_data
11278 !      include 'DIMENSIONS'
11279 !      include 'COMMON.CHAIN'
11280 !      include 'COMMON.DERIV'
11281 !      include 'COMMON.CALC'
11282 !      include 'COMMON.IOUNITS'
11283       real(kind=8), dimension(3) :: dcosom1,dcosom2
11284 !      print *,"wchodze"
11285       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11286           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11287       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11288           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11289
11290       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11291            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11292            +dCAVdOM12+ dGCLdOM12
11293 ! diagnostics only
11294 !      eom1=0.0d0
11295 !      eom2=0.0d0
11296 !      eom12=evdwij*eps1_om12
11297 ! end diagnostics
11298 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11299 !       " sigder",sigder
11300 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11301 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11302 !C      print *,sss_ele_cut,'in sc_grad'
11303       do k=1,3
11304         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11305         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11306       enddo
11307       do k=1,3
11308         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11309 !C      print *,'gg',k,gg(k)
11310        enddo
11311 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11312 !      write (iout,*) "gg",(gg(k),k=1,3)
11313       do k=1,3
11314         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11315                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11316                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11317                   *sss_ele_cut
11318
11319         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11320                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11321                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11322                   *sss_ele_cut
11323
11324 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11325 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11326 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11327 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11328       enddo
11329 !
11330 ! Calculate the components of the gradient in DC and X
11331 !
11332 !grad      do k=i,j-1
11333 !grad        do l=1,3
11334 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11335 !grad        enddo
11336 !grad      enddo
11337       do l=1,3
11338         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11339         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11340       enddo
11341       return
11342       end subroutine sc_grad
11343 #ifdef CRYST_THETA
11344 !-----------------------------------------------------------------------------
11345       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11346
11347       use comm_calcthet
11348 !      implicit real*8 (a-h,o-z)
11349 !      include 'DIMENSIONS'
11350 !      include 'COMMON.LOCAL'
11351 !      include 'COMMON.IOUNITS'
11352 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11353 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11354 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11355       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11356       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11357 !el      integer :: it
11358 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11359 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11360 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11361 !el local variables
11362
11363       delthec=thetai-thet_pred_mean
11364       delthe0=thetai-theta0i
11365 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11366       t3 = thetai-thet_pred_mean
11367       t6 = t3**2
11368       t9 = term1
11369       t12 = t3*sigcsq
11370       t14 = t12+t6*sigsqtc
11371       t16 = 1.0d0
11372       t21 = thetai-theta0i
11373       t23 = t21**2
11374       t26 = term2
11375       t27 = t21*t26
11376       t32 = termexp
11377       t40 = t32**2
11378       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11379        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11380        *(-t12*t9-ak*sig0inv*t27)
11381       return
11382       end subroutine mixder
11383 #endif
11384 !-----------------------------------------------------------------------------
11385 ! cartder.F
11386 !-----------------------------------------------------------------------------
11387       subroutine cartder
11388 !-----------------------------------------------------------------------------
11389 ! This subroutine calculates the derivatives of the consecutive virtual
11390 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11391 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11392 ! in the angles alpha and omega, describing the location of a side chain
11393 ! in its local coordinate system.
11394 !
11395 ! The derivatives are stored in the following arrays:
11396 !
11397 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11398 ! The structure is as follows:
11399 !
11400 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11401 ! 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)
11402 !         . . . . . . . . . . . .  . . . . . .
11403 ! 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)
11404 !                          .
11405 !                          .
11406 !                          .
11407 ! 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)
11408 !
11409 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11410 ! The structure is same as above.
11411 !
11412 ! DCDS - the derivatives of the side chain vectors in the local spherical
11413 ! andgles alph and omega:
11414 !
11415 ! 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)
11416 ! 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)
11417 !                          .
11418 !                          .
11419 !                          .
11420 ! 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)
11421 !
11422 ! Version of March '95, based on an early version of November '91.
11423 !
11424 !**********************************************************************
11425 !      implicit real*8 (a-h,o-z)
11426 !      include 'DIMENSIONS'
11427 !      include 'COMMON.VAR'
11428 !      include 'COMMON.CHAIN'
11429 !      include 'COMMON.DERIV'
11430 !      include 'COMMON.GEO'
11431 !      include 'COMMON.LOCAL'
11432 !      include 'COMMON.INTERACT'
11433       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11434       real(kind=8),dimension(3,3) :: dp,temp
11435 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11436       real(kind=8),dimension(3) :: xx,xx1
11437 !el local variables
11438       integer :: i,k,l,j,m,ind,ind1,jjj
11439       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11440                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11441                  sint2,xp,yp,xxp,yyp,zzp,dj
11442
11443 !      common /przechowalnia/ fromto
11444       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11445 ! get the position of the jth ijth fragment of the chain coordinate system
11446 ! in the fromto array.
11447 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11448 !
11449 !      maxdim=(nres-1)*(nres-2)/2
11450 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11451 ! calculate the derivatives of transformation matrix elements in theta
11452 !
11453
11454 !el      call flush(iout) !el
11455       do i=1,nres-2
11456         rdt(1,1,i)=-rt(1,2,i)
11457         rdt(1,2,i)= rt(1,1,i)
11458         rdt(1,3,i)= 0.0d0
11459         rdt(2,1,i)=-rt(2,2,i)
11460         rdt(2,2,i)= rt(2,1,i)
11461         rdt(2,3,i)= 0.0d0
11462         rdt(3,1,i)=-rt(3,2,i)
11463         rdt(3,2,i)= rt(3,1,i)
11464         rdt(3,3,i)= 0.0d0
11465       enddo
11466 !
11467 ! derivatives in phi
11468 !
11469       do i=2,nres-2
11470         drt(1,1,i)= 0.0d0
11471         drt(1,2,i)= 0.0d0
11472         drt(1,3,i)= 0.0d0
11473         drt(2,1,i)= rt(3,1,i)
11474         drt(2,2,i)= rt(3,2,i)
11475         drt(2,3,i)= rt(3,3,i)
11476         drt(3,1,i)=-rt(2,1,i)
11477         drt(3,2,i)=-rt(2,2,i)
11478         drt(3,3,i)=-rt(2,3,i)
11479       enddo
11480 !
11481 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
11482 !
11483       do i=2,nres-2
11484         ind=indmat(i,i+1)
11485         do k=1,3
11486           do l=1,3
11487             temp(k,l)=rt(k,l,i)
11488           enddo
11489         enddo
11490         do k=1,3
11491           do l=1,3
11492             fromto(k,l,ind)=temp(k,l)
11493           enddo
11494         enddo
11495         do j=i+1,nres-2
11496           ind=indmat(i,j+1)
11497           do k=1,3
11498             do l=1,3
11499               dpkl=0.0d0
11500               do m=1,3
11501                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
11502               enddo
11503               dp(k,l)=dpkl
11504               fromto(k,l,ind)=dpkl
11505             enddo
11506           enddo
11507           do k=1,3
11508             do l=1,3
11509               temp(k,l)=dp(k,l)
11510             enddo
11511           enddo
11512         enddo
11513       enddo
11514 !
11515 ! Calculate derivatives.
11516 !
11517       ind1=0
11518       do i=1,nres-2
11519       ind1=ind1+1
11520 !
11521 ! Derivatives of DC(i+1) in theta(i+2)
11522 !
11523         do j=1,3
11524           do k=1,2
11525             dpjk=0.0D0
11526             do l=1,3
11527               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
11528             enddo
11529             dp(j,k)=dpjk
11530             prordt(j,k,i)=dp(j,k)
11531           enddo
11532           dp(j,3)=0.0D0
11533           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
11534         enddo
11535 !
11536 ! Derivatives of SC(i+1) in theta(i+2)
11537 !
11538         xx1(1)=-0.5D0*xloc(2,i+1)
11539         xx1(2)= 0.5D0*xloc(1,i+1)
11540         do j=1,3
11541           xj=0.0D0
11542           do k=1,2
11543             xj=xj+r(j,k,i)*xx1(k)
11544           enddo
11545           xx(j)=xj
11546         enddo
11547         do j=1,3
11548           rj=0.0D0
11549           do k=1,3
11550             rj=rj+prod(j,k,i)*xx(k)
11551           enddo
11552           dxdv(j,ind1)=rj
11553         enddo
11554 !
11555 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
11556 ! than the other off-diagonal derivatives.
11557 !
11558         do j=1,3
11559           dxoiij=0.0D0
11560           do k=1,3
11561             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11562           enddo
11563           dxdv(j,ind1+1)=dxoiij
11564         enddo
11565 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
11566 !
11567 ! Derivatives of DC(i+1) in phi(i+2)
11568 !
11569         do j=1,3
11570           do k=1,3
11571             dpjk=0.0
11572             do l=2,3
11573               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
11574             enddo
11575             dp(j,k)=dpjk
11576             prodrt(j,k,i)=dp(j,k)
11577           enddo
11578           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
11579         enddo
11580 !
11581 ! Derivatives of SC(i+1) in phi(i+2)
11582 !
11583         xx(1)= 0.0D0
11584         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
11585         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
11586         do j=1,3
11587           rj=0.0D0
11588           do k=2,3
11589             rj=rj+prod(j,k,i)*xx(k)
11590           enddo
11591           dxdv(j+3,ind1)=-rj
11592         enddo
11593 !
11594 ! Derivatives of SC(i+1) in phi(i+3).
11595 !
11596         do j=1,3
11597           dxoiij=0.0D0
11598           do k=1,3
11599             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11600           enddo
11601           dxdv(j+3,ind1+1)=dxoiij
11602         enddo
11603 !
11604 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
11605 ! theta(nres) and phi(i+3) thru phi(nres).
11606 !
11607         do j=i+1,nres-2
11608         ind1=ind1+1
11609         ind=indmat(i+1,j+1)
11610 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
11611           do k=1,3
11612             do l=1,3
11613               tempkl=0.0D0
11614               do m=1,2
11615                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
11616               enddo
11617               temp(k,l)=tempkl
11618             enddo
11619           enddo
11620 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
11621 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
11622 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
11623 ! Derivatives of virtual-bond vectors in theta
11624           do k=1,3
11625             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
11626           enddo
11627 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
11628 ! Derivatives of SC vectors in theta
11629           do k=1,3
11630             dxoijk=0.0D0
11631             do l=1,3
11632               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11633             enddo
11634             dxdv(k,ind1+1)=dxoijk
11635           enddo
11636 !
11637 !--- Calculate the derivatives in phi
11638 !
11639           do k=1,3
11640             do l=1,3
11641               tempkl=0.0D0
11642               do m=1,3
11643                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
11644               enddo
11645               temp(k,l)=tempkl
11646             enddo
11647           enddo
11648           do k=1,3
11649             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
11650         enddo
11651           do k=1,3
11652             dxoijk=0.0D0
11653             do l=1,3
11654               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11655             enddo
11656             dxdv(k+3,ind1+1)=dxoijk
11657           enddo
11658         enddo
11659       enddo
11660 !
11661 ! Derivatives in alpha and omega:
11662 !
11663       do i=2,nres-1
11664 !       dsci=dsc(itype(i,1))
11665         dsci=vbld(i+nres)
11666 #ifdef OSF
11667         alphi=alph(i)
11668         omegi=omeg(i)
11669         if(alphi.ne.alphi) alphi=100.0
11670         if(omegi.ne.omegi) omegi=-100.0
11671 #else
11672       alphi=alph(i)
11673       omegi=omeg(i)
11674 #endif
11675 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
11676       cosalphi=dcos(alphi)
11677       sinalphi=dsin(alphi)
11678       cosomegi=dcos(omegi)
11679       sinomegi=dsin(omegi)
11680       temp(1,1)=-dsci*sinalphi
11681       temp(2,1)= dsci*cosalphi*cosomegi
11682       temp(3,1)=-dsci*cosalphi*sinomegi
11683       temp(1,2)=0.0D0
11684       temp(2,2)=-dsci*sinalphi*sinomegi
11685       temp(3,2)=-dsci*sinalphi*cosomegi
11686       theta2=pi-0.5D0*theta(i+1)
11687       cost2=dcos(theta2)
11688       sint2=dsin(theta2)
11689       jjj=0
11690 !d      print *,((temp(l,k),l=1,3),k=1,2)
11691         do j=1,2
11692         xp=temp(1,j)
11693         yp=temp(2,j)
11694         xxp= xp*cost2+yp*sint2
11695         yyp=-xp*sint2+yp*cost2
11696         zzp=temp(3,j)
11697         xx(1)=xxp
11698         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
11699         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
11700         do k=1,3
11701           dj=0.0D0
11702           do l=1,3
11703             dj=dj+prod(k,l,i-1)*xx(l)
11704             enddo
11705           dxds(jjj+k,i)=dj
11706           enddo
11707         jjj=jjj+3
11708       enddo
11709       enddo
11710       return
11711       end subroutine cartder
11712 !-----------------------------------------------------------------------------
11713 ! checkder_p.F
11714 !-----------------------------------------------------------------------------
11715       subroutine check_cartgrad
11716 ! Check the gradient of Cartesian coordinates in internal coordinates.
11717 !      implicit real*8 (a-h,o-z)
11718 !      include 'DIMENSIONS'
11719 !      include 'COMMON.IOUNITS'
11720 !      include 'COMMON.VAR'
11721 !      include 'COMMON.CHAIN'
11722 !      include 'COMMON.GEO'
11723 !      include 'COMMON.LOCAL'
11724 !      include 'COMMON.DERIV'
11725       real(kind=8),dimension(6,nres) :: temp
11726       real(kind=8),dimension(3) :: xx,gg
11727       integer :: i,k,j,ii
11728       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
11729 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11730 !
11731 ! Check the gradient of the virtual-bond and SC vectors in the internal
11732 ! coordinates.
11733 !
11734       aincr=1.0d-6
11735       aincr2=5.0d-7
11736       call cartder
11737       write (iout,'(a)') '**************** dx/dalpha'
11738       write (iout,'(a)')
11739       do i=2,nres-1
11740       alphi=alph(i)
11741       alph(i)=alph(i)+aincr
11742       do k=1,3
11743         temp(k,i)=dc(k,nres+i)
11744         enddo
11745       call chainbuild
11746       do k=1,3
11747         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11748         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11749         enddo
11750         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11751         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11752         write (iout,'(a)')
11753       alph(i)=alphi
11754       call chainbuild
11755       enddo
11756       write (iout,'(a)')
11757       write (iout,'(a)') '**************** dx/domega'
11758       write (iout,'(a)')
11759       do i=2,nres-1
11760       omegi=omeg(i)
11761       omeg(i)=omeg(i)+aincr
11762       do k=1,3
11763         temp(k,i)=dc(k,nres+i)
11764         enddo
11765       call chainbuild
11766       do k=1,3
11767           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11768           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11769                 (aincr*dabs(dxds(k+3,i))+aincr))
11770         enddo
11771         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11772             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11773         write (iout,'(a)')
11774       omeg(i)=omegi
11775       call chainbuild
11776       enddo
11777       write (iout,'(a)')
11778       write (iout,'(a)') '**************** dx/dtheta'
11779       write (iout,'(a)')
11780       do i=3,nres
11781       theti=theta(i)
11782         theta(i)=theta(i)+aincr
11783         do j=i-1,nres-1
11784           do k=1,3
11785             temp(k,j)=dc(k,nres+j)
11786           enddo
11787         enddo
11788         call chainbuild
11789         do j=i-1,nres-1
11790         ii = indmat(i-2,j)
11791 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11792         do k=1,3
11793           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11794           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11795                   (aincr*dabs(dxdv(k,ii))+aincr))
11796           enddo
11797           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11798               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11799           write(iout,'(a)')
11800         enddo
11801         write (iout,'(a)')
11802         theta(i)=theti
11803         call chainbuild
11804       enddo
11805       write (iout,'(a)') '***************** dx/dphi'
11806       write (iout,'(a)')
11807       do i=4,nres
11808         phi(i)=phi(i)+aincr
11809         do j=i-1,nres-1
11810           do k=1,3
11811             temp(k,j)=dc(k,nres+j)
11812           enddo
11813         enddo
11814         call chainbuild
11815         do j=i-1,nres-1
11816         ii = indmat(i-2,j)
11817 !         print *,'ii=',ii
11818         do k=1,3
11819           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11820             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
11821                   (aincr*dabs(dxdv(k+3,ii))+aincr))
11822           enddo
11823           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11824               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11825           write(iout,'(a)')
11826         enddo
11827         phi(i)=phi(i)-aincr
11828         call chainbuild
11829       enddo
11830       write (iout,'(a)') '****************** ddc/dtheta'
11831       do i=1,nres-2
11832         thet=theta(i+2)
11833         theta(i+2)=thet+aincr
11834         do j=i,nres
11835           do k=1,3
11836             temp(k,j)=dc(k,j)
11837           enddo
11838         enddo
11839         call chainbuild
11840         do j=i+1,nres-1
11841         ii = indmat(i,j)
11842 !         print *,'ii=',ii
11843         do k=1,3
11844           gg(k)=(dc(k,j)-temp(k,j))/aincr
11845           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11846                  (aincr*dabs(dcdv(k,ii))+aincr))
11847           enddo
11848           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11849                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11850         write (iout,'(a)')
11851         enddo
11852         do j=1,nres
11853           do k=1,3
11854             dc(k,j)=temp(k,j)
11855           enddo
11856         enddo
11857         theta(i+2)=thet
11858       enddo
11859       write (iout,'(a)') '******************* ddc/dphi'
11860       do i=1,nres-3
11861         phii=phi(i+3)
11862         phi(i+3)=phii+aincr
11863         do j=1,nres
11864           do k=1,3
11865             temp(k,j)=dc(k,j)
11866           enddo
11867         enddo
11868         call chainbuild
11869         do j=i+2,nres-1
11870         ii = indmat(i+1,j)
11871 !         print *,'ii=',ii
11872         do k=1,3
11873           gg(k)=(dc(k,j)-temp(k,j))/aincr
11874             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11875                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11876           enddo
11877           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11878                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11879         write (iout,'(a)')
11880         enddo
11881         do j=1,nres
11882           do k=1,3
11883             dc(k,j)=temp(k,j)
11884           enddo
11885         enddo
11886         phi(i+3)=phii
11887       enddo
11888       return
11889       end subroutine check_cartgrad
11890 !-----------------------------------------------------------------------------
11891       subroutine check_ecart
11892 ! Check the gradient of the energy in Cartesian coordinates.
11893 !     implicit real*8 (a-h,o-z)
11894 !     include 'DIMENSIONS'
11895 !     include 'COMMON.CHAIN'
11896 !     include 'COMMON.DERIV'
11897 !     include 'COMMON.IOUNITS'
11898 !     include 'COMMON.VAR'
11899 !     include 'COMMON.CONTACTS'
11900       use comm_srutu
11901 !el      integer :: icall
11902 !el      common /srutu/ icall
11903       real(kind=8),dimension(6) :: ggg
11904       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11905       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11906       real(kind=8),dimension(6,nres) :: grad_s
11907       real(kind=8),dimension(0:n_ene) :: energia,energia1
11908       integer :: uiparm(1)
11909       real(kind=8) :: urparm(1)
11910 !EL      external fdum
11911       integer :: nf,i,j,k
11912       real(kind=8) :: aincr,etot,etot1
11913       icg=1
11914       nf=0
11915       nfl=0
11916       call zerograd
11917       aincr=1.0D-5
11918       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11919       nf=0
11920       icall=0
11921       call geom_to_var(nvar,x)
11922       call etotal(energia)
11923       etot=energia(0)
11924 !el      call enerprint(energia)
11925       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11926       icall =1
11927       do i=1,nres
11928         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11929       enddo
11930       do i=1,nres
11931       do j=1,3
11932         grad_s(j,i)=gradc(j,i,icg)
11933         grad_s(j+3,i)=gradx(j,i,icg)
11934         enddo
11935       enddo
11936       call flush(iout)
11937       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11938       do i=1,nres
11939         do j=1,3
11940         xx(j)=c(j,i+nres)
11941         ddc(j)=dc(j,i)
11942         ddx(j)=dc(j,i+nres)
11943         enddo
11944       do j=1,3
11945         dc(j,i)=dc(j,i)+aincr
11946         do k=i+1,nres
11947           c(j,k)=c(j,k)+aincr
11948           c(j,k+nres)=c(j,k+nres)+aincr
11949           enddo
11950           call zerograd
11951           call etotal(energia1)
11952           etot1=energia1(0)
11953         ggg(j)=(etot1-etot)/aincr
11954         dc(j,i)=ddc(j)
11955         do k=i+1,nres
11956           c(j,k)=c(j,k)-aincr
11957           c(j,k+nres)=c(j,k+nres)-aincr
11958           enddo
11959         enddo
11960       do j=1,3
11961         c(j,i+nres)=c(j,i+nres)+aincr
11962         dc(j,i+nres)=dc(j,i+nres)+aincr
11963           call zerograd
11964           call etotal(energia1)
11965           etot1=energia1(0)
11966         ggg(j+3)=(etot1-etot)/aincr
11967         c(j,i+nres)=xx(j)
11968         dc(j,i+nres)=ddx(j)
11969         enddo
11970       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11971          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11972       enddo
11973       return
11974       end subroutine check_ecart
11975 #ifdef CARGRAD
11976 !-----------------------------------------------------------------------------
11977       subroutine check_ecartint
11978 ! Check the gradient of the energy in Cartesian coordinates.
11979       use io_base, only: intout
11980 !      implicit real*8 (a-h,o-z)
11981 !      include 'DIMENSIONS'
11982 !      include 'COMMON.CONTROL'
11983 !      include 'COMMON.CHAIN'
11984 !      include 'COMMON.DERIV'
11985 !      include 'COMMON.IOUNITS'
11986 !      include 'COMMON.VAR'
11987 !      include 'COMMON.CONTACTS'
11988 !      include 'COMMON.MD'
11989 !      include 'COMMON.LOCAL'
11990 !      include 'COMMON.SPLITELE'
11991       use comm_srutu
11992 !el      integer :: icall
11993 !el      common /srutu/ icall
11994       real(kind=8),dimension(6) :: ggg,ggg1
11995       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11996       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11997       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11998       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11999       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12000       real(kind=8),dimension(0:n_ene) :: energia,energia1
12001       integer :: uiparm(1)
12002       real(kind=8) :: urparm(1)
12003 !EL      external fdum
12004       integer :: i,j,k,nf
12005       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12006                    etot21,etot22
12007       r_cut=2.0d0
12008       rlambd=0.3d0
12009       icg=1
12010       nf=0
12011       nfl=0
12012       call intout
12013 !      call intcartderiv
12014 !      call checkintcartgrad
12015       call zerograd
12016       aincr=1.0D-4
12017       write(iout,*) 'Calling CHECK_ECARTINT.'
12018       nf=0
12019       icall=0
12020       call geom_to_var(nvar,x)
12021       write (iout,*) "split_ene ",split_ene
12022       call flush(iout)
12023       if (.not.split_ene) then
12024         call zerograd
12025         call etotal(energia)
12026         etot=energia(0)
12027         call cartgrad
12028         icall =1
12029         do i=1,nres
12030           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12031         enddo
12032         do j=1,3
12033           grad_s(j,0)=gcart(j,0)
12034         enddo
12035         do i=1,nres
12036           do j=1,3
12037             grad_s(j,i)=gcart(j,i)
12038             grad_s(j+3,i)=gxcart(j,i)
12039           enddo
12040         enddo
12041       else
12042 !- split gradient check
12043         call zerograd
12044         call etotal_long(energia)
12045 !el        call enerprint(energia)
12046         call cartgrad
12047         icall =1
12048         do i=1,nres
12049           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12050           (gxcart(j,i),j=1,3)
12051         enddo
12052         do j=1,3
12053           grad_s(j,0)=gcart(j,0)
12054         enddo
12055         do i=1,nres
12056           do j=1,3
12057             grad_s(j,i)=gcart(j,i)
12058             grad_s(j+3,i)=gxcart(j,i)
12059           enddo
12060         enddo
12061         call zerograd
12062         call etotal_short(energia)
12063         call enerprint(energia)
12064         call cartgrad
12065         icall =1
12066         do i=1,nres
12067           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12068           (gxcart(j,i),j=1,3)
12069         enddo
12070         do j=1,3
12071           grad_s1(j,0)=gcart(j,0)
12072         enddo
12073         do i=1,nres
12074           do j=1,3
12075             grad_s1(j,i)=gcart(j,i)
12076             grad_s1(j+3,i)=gxcart(j,i)
12077           enddo
12078         enddo
12079       endif
12080       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12081 !      do i=1,nres
12082       do i=nnt,nct
12083         do j=1,3
12084           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
12085           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
12086         ddc(j)=c(j,i)
12087         ddx(j)=c(j,i+nres)
12088           dcnorm_safe1(j)=dc_norm(j,i-1)
12089           dcnorm_safe2(j)=dc_norm(j,i)
12090           dxnorm_safe(j)=dc_norm(j,i+nres)
12091         enddo
12092       do j=1,3
12093         c(j,i)=ddc(j)+aincr
12094           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
12095           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
12096           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12097           dc(j,i)=c(j,i+1)-c(j,i)
12098           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12099           call int_from_cart1(.false.)
12100           if (.not.split_ene) then
12101            call zerograd
12102             call etotal(energia1)
12103             etot1=energia1(0)
12104             write (iout,*) "ij",i,j," etot1",etot1
12105           else
12106 !- split gradient
12107             call etotal_long(energia1)
12108             etot11=energia1(0)
12109             call etotal_short(energia1)
12110             etot12=energia1(0)
12111           endif
12112 !- end split gradient
12113 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12114         c(j,i)=ddc(j)-aincr
12115           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
12116           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
12117           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12118           dc(j,i)=c(j,i+1)-c(j,i)
12119           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12120           call int_from_cart1(.false.)
12121           if (.not.split_ene) then
12122             call zerograd
12123             call etotal(energia1)
12124             etot2=energia1(0)
12125             write (iout,*) "ij",i,j," etot2",etot2
12126           ggg(j)=(etot1-etot2)/(2*aincr)
12127           else
12128 !- split gradient
12129             call etotal_long(energia1)
12130             etot21=energia1(0)
12131           ggg(j)=(etot11-etot21)/(2*aincr)
12132             call etotal_short(energia1)
12133             etot22=energia1(0)
12134           ggg1(j)=(etot12-etot22)/(2*aincr)
12135 !- end split gradient
12136 !            write (iout,*) "etot21",etot21," etot22",etot22
12137           endif
12138 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12139         c(j,i)=ddc(j)
12140           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
12141           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
12142           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
12143           dc(j,i)=c(j,i+1)-c(j,i)
12144           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12145           dc_norm(j,i-1)=dcnorm_safe1(j)
12146           dc_norm(j,i)=dcnorm_safe2(j)
12147           dc_norm(j,i+nres)=dxnorm_safe(j)
12148         enddo
12149       do j=1,3
12150         c(j,i+nres)=ddx(j)+aincr
12151           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12152           call int_from_cart1(.false.)
12153           if (.not.split_ene) then
12154             call zerograd
12155             call etotal(energia1)
12156             etot1=energia1(0)
12157           else
12158 !- split gradient
12159             call etotal_long(energia1)
12160             etot11=energia1(0)
12161             call etotal_short(energia1)
12162             etot12=energia1(0)
12163           endif
12164 !- end split gradient
12165         c(j,i+nres)=ddx(j)-aincr
12166           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12167           call int_from_cart1(.false.)
12168           if (.not.split_ene) then
12169            call zerograd
12170            call etotal(energia1)
12171             etot2=energia1(0)
12172           ggg(j+3)=(etot1-etot2)/(2*aincr)
12173           else
12174 !- split gradient
12175             call etotal_long(energia1)
12176             etot21=energia1(0)
12177           ggg(j+3)=(etot11-etot21)/(2*aincr)
12178             call etotal_short(energia1)
12179             etot22=energia1(0)
12180           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12181 !- end split gradient
12182           endif
12183 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12184         c(j,i+nres)=ddx(j)
12185           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12186           dc_norm(j,i+nres)=dxnorm_safe(j)
12187           call int_from_cart1(.false.)
12188         enddo
12189       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12190          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12191         if (split_ene) then
12192           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12193          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12194          k=1,6)
12195          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12196          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12197          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12198         endif
12199       enddo
12200       return
12201       end subroutine check_ecartint
12202 #else
12203 !-----------------------------------------------------------------------------
12204       subroutine check_ecartint
12205 ! Check the gradient of the energy in Cartesian coordinates.
12206       use io_base, only: intout
12207 !      implicit real*8 (a-h,o-z)
12208 !      include 'DIMENSIONS'
12209 !      include 'COMMON.CONTROL'
12210 !      include 'COMMON.CHAIN'
12211 !      include 'COMMON.DERIV'
12212 !      include 'COMMON.IOUNITS'
12213 !      include 'COMMON.VAR'
12214 !      include 'COMMON.CONTACTS'
12215 !      include 'COMMON.MD'
12216 !      include 'COMMON.LOCAL'
12217 !      include 'COMMON.SPLITELE'
12218       use comm_srutu
12219 !el      integer :: icall
12220 !el      common /srutu/ icall
12221       real(kind=8),dimension(6) :: ggg,ggg1
12222       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12223       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12224       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12225       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12226       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12227       real(kind=8),dimension(0:n_ene) :: energia,energia1
12228       integer :: uiparm(1)
12229       real(kind=8) :: urparm(1)
12230 !EL      external fdum
12231       integer :: i,j,k,nf
12232       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12233                    etot21,etot22
12234       r_cut=2.0d0
12235       rlambd=0.3d0
12236       icg=1
12237       nf=0
12238       nfl=0
12239       call intout
12240 !      call intcartderiv
12241 !      call checkintcartgrad
12242       call zerograd
12243       aincr=2.0D-5
12244       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12245       nf=0
12246       icall=0
12247       call geom_to_var(nvar,x)
12248       if (.not.split_ene) then
12249         call etotal(energia)
12250         etot=energia(0)
12251 !el        call enerprint(energia)
12252         call cartgrad
12253         icall =1
12254         do i=1,nres
12255           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12256         enddo
12257         do j=1,3
12258           grad_s(j,0)=gcart(j,0)
12259         enddo
12260         do i=1,nres
12261           do j=1,3
12262             grad_s(j,i)=gcart(j,i)
12263 !              if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12264
12265 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12266             grad_s(j+3,i)=gxcart(j,i)
12267           enddo
12268         enddo
12269       else
12270 !- split gradient check
12271         call zerograd
12272         call etotal_long(energia)
12273 !el        call enerprint(energia)
12274         call cartgrad
12275         icall =1
12276         do i=1,nres
12277           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12278           (gxcart(j,i),j=1,3)
12279         enddo
12280         do j=1,3
12281           grad_s(j,0)=gcart(j,0)
12282         enddo
12283         do i=1,nres
12284           do j=1,3
12285             grad_s(j,i)=gcart(j,i)
12286 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12287             grad_s(j+3,i)=gxcart(j,i)
12288           enddo
12289         enddo
12290         call zerograd
12291         call etotal_short(energia)
12292 !el        call enerprint(energia)
12293         call cartgrad
12294         icall =1
12295         do i=1,nres
12296           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12297           (gxcart(j,i),j=1,3)
12298         enddo
12299         do j=1,3
12300           grad_s1(j,0)=gcart(j,0)
12301         enddo
12302         do i=1,nres
12303           do j=1,3
12304             grad_s1(j,i)=gcart(j,i)
12305             grad_s1(j+3,i)=gxcart(j,i)
12306           enddo
12307         enddo
12308       endif
12309       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12310       do i=0,nres
12311         do j=1,3
12312         xx(j)=c(j,i+nres)
12313         ddc(j)=dc(j,i)
12314         ddx(j)=dc(j,i+nres)
12315           do k=1,3
12316             dcnorm_safe(k)=dc_norm(k,i)
12317             dxnorm_safe(k)=dc_norm(k,i+nres)
12318           enddo
12319         enddo
12320       do j=1,3
12321         dc(j,i)=ddc(j)+aincr
12322           call chainbuild_cart
12323 #ifdef MPI
12324 ! Broadcast the order to compute internal coordinates to the slaves.
12325 !          if (nfgtasks.gt.1)
12326 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12327 #endif
12328 !          call int_from_cart1(.false.)
12329           if (.not.split_ene) then
12330            call zerograd
12331             call etotal(energia1)
12332             etot1=energia1(0)
12333 !            call enerprint(energia1)
12334           else
12335 !- split gradient
12336             call etotal_long(energia1)
12337             etot11=energia1(0)
12338             call etotal_short(energia1)
12339             etot12=energia1(0)
12340 !            write (iout,*) "etot11",etot11," etot12",etot12
12341           endif
12342 !- end split gradient
12343 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12344         dc(j,i)=ddc(j)-aincr
12345           call chainbuild_cart
12346 !          call int_from_cart1(.false.)
12347           if (.not.split_ene) then
12348                   call zerograd
12349             call etotal(energia1)
12350             etot2=energia1(0)
12351           ggg(j)=(etot1-etot2)/(2*aincr)
12352           else
12353 !- split gradient
12354             call etotal_long(energia1)
12355             etot21=energia1(0)
12356           ggg(j)=(etot11-etot21)/(2*aincr)
12357             call etotal_short(energia1)
12358             etot22=energia1(0)
12359           ggg1(j)=(etot12-etot22)/(2*aincr)
12360 !- end split gradient
12361 !            write (iout,*) "etot21",etot21," etot22",etot22
12362           endif
12363 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12364         dc(j,i)=ddc(j)
12365           call chainbuild_cart
12366         enddo
12367       do j=1,3
12368         dc(j,i+nres)=ddx(j)+aincr
12369           call chainbuild_cart
12370 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12371 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12372 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12373 !          write (iout,*) "dxnormnorm",dsqrt(
12374 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12375 !          write (iout,*) "dxnormnormsafe",dsqrt(
12376 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12377 !          write (iout,*)
12378           if (.not.split_ene) then
12379             call zerograd
12380             call etotal(energia1)
12381             etot1=energia1(0)
12382           else
12383 !- split gradient
12384             call etotal_long(energia1)
12385             etot11=energia1(0)
12386             call etotal_short(energia1)
12387             etot12=energia1(0)
12388           endif
12389 !- end split gradient
12390 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12391         dc(j,i+nres)=ddx(j)-aincr
12392           call chainbuild_cart
12393 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12394 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12395 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12396 !          write (iout,*)
12397 !          write (iout,*) "dxnormnorm",dsqrt(
12398 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12399 !          write (iout,*) "dxnormnormsafe",dsqrt(
12400 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12401           if (.not.split_ene) then
12402             call zerograd
12403             call etotal(energia1)
12404             etot2=energia1(0)
12405           ggg(j+3)=(etot1-etot2)/(2*aincr)
12406           else
12407 !- split gradient
12408             call etotal_long(energia1)
12409             etot21=energia1(0)
12410           ggg(j+3)=(etot11-etot21)/(2*aincr)
12411             call etotal_short(energia1)
12412             etot22=energia1(0)
12413           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12414 !- end split gradient
12415           endif
12416 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12417         dc(j,i+nres)=ddx(j)
12418           call chainbuild_cart
12419         enddo
12420       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12421          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12422         if (split_ene) then
12423           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12424          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12425          k=1,6)
12426          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12427          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12428          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12429         endif
12430       enddo
12431       return
12432       end subroutine check_ecartint
12433 #endif
12434 !-----------------------------------------------------------------------------
12435       subroutine check_eint
12436 ! Check the gradient of energy in internal coordinates.
12437 !      implicit real*8 (a-h,o-z)
12438 !      include 'DIMENSIONS'
12439 !      include 'COMMON.CHAIN'
12440 !      include 'COMMON.DERIV'
12441 !      include 'COMMON.IOUNITS'
12442 !      include 'COMMON.VAR'
12443 !      include 'COMMON.GEO'
12444       use comm_srutu
12445 !el      integer :: icall
12446 !el      common /srutu/ icall
12447       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12448       integer :: uiparm(1)
12449       real(kind=8) :: urparm(1)
12450       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12451       character(len=6) :: key
12452 !EL      external fdum
12453       integer :: i,ii,nf
12454       real(kind=8) :: xi,aincr,etot,etot1,etot2
12455       call zerograd
12456       aincr=1.0D-7
12457       print '(a)','Calling CHECK_INT.'
12458       nf=0
12459       nfl=0
12460       icg=1
12461       call geom_to_var(nvar,x)
12462       call var_to_geom(nvar,x)
12463       call chainbuild
12464       icall=1
12465 !      print *,'ICG=',ICG
12466       call etotal(energia)
12467       etot = energia(0)
12468 !el      call enerprint(energia)
12469 !      print *,'ICG=',ICG
12470 #ifdef MPL
12471       if (MyID.ne.BossID) then
12472         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12473         nf=x(nvar+1)
12474         nfl=x(nvar+2)
12475         icg=x(nvar+3)
12476       endif
12477 #endif
12478       nf=1
12479       nfl=3
12480 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12481       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12482 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12483       icall=1
12484       do i=1,nvar
12485         xi=x(i)
12486         x(i)=xi-0.5D0*aincr
12487         call var_to_geom(nvar,x)
12488         call chainbuild
12489         call etotal(energia1)
12490         etot1=energia1(0)
12491         x(i)=xi+0.5D0*aincr
12492         call var_to_geom(nvar,x)
12493         call chainbuild
12494         call etotal(energia2)
12495         etot2=energia2(0)
12496         gg(i)=(etot2-etot1)/aincr
12497         write (iout,*) i,etot1,etot2
12498         x(i)=xi
12499       enddo
12500       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
12501           '     RelDiff*100% '
12502       do i=1,nvar
12503         if (i.le.nphi) then
12504           ii=i
12505           key = ' phi'
12506         else if (i.le.nphi+ntheta) then
12507           ii=i-nphi
12508           key=' theta'
12509         else if (i.le.nphi+ntheta+nside) then
12510            ii=i-(nphi+ntheta)
12511            key=' alpha'
12512         else
12513            ii=i-(nphi+ntheta+nside)
12514            key=' omega'
12515         endif
12516         write (iout,'(i3,a,i3,3(1pd16.6))') &
12517        i,key,ii,gg(i),gana(i),&
12518        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
12519       enddo
12520       return
12521       end subroutine check_eint
12522 !-----------------------------------------------------------------------------
12523 ! econstr_local.F
12524 !-----------------------------------------------------------------------------
12525       subroutine Econstr_back
12526 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
12527 !      implicit real*8 (a-h,o-z)
12528 !      include 'DIMENSIONS'
12529 !      include 'COMMON.CONTROL'
12530 !      include 'COMMON.VAR'
12531 !      include 'COMMON.MD'
12532       use MD_data
12533 !#ifndef LANG0
12534 !      include 'COMMON.LANGEVIN'
12535 !#else
12536 !      include 'COMMON.LANGEVIN.lang0'
12537 !#endif
12538 !      include 'COMMON.CHAIN'
12539 !      include 'COMMON.DERIV'
12540 !      include 'COMMON.GEO'
12541 !      include 'COMMON.LOCAL'
12542 !      include 'COMMON.INTERACT'
12543 !      include 'COMMON.IOUNITS'
12544 !      include 'COMMON.NAMES'
12545 !      include 'COMMON.TIME1'
12546       integer :: i,j,ii,k
12547       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
12548
12549       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
12550       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
12551       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
12552
12553       Uconst_back=0.0d0
12554       do i=1,nres
12555         dutheta(i)=0.0d0
12556         dugamma(i)=0.0d0
12557         do j=1,3
12558           duscdiff(j,i)=0.0d0
12559           duscdiffx(j,i)=0.0d0
12560         enddo
12561       enddo
12562       do i=1,nfrag_back
12563         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
12564 !
12565 ! Deviations from theta angles
12566 !
12567         utheta_i=0.0d0
12568         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
12569           dtheta_i=theta(j)-thetaref(j)
12570           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
12571           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
12572         enddo
12573         utheta(i)=utheta_i/(ii-1)
12574 !
12575 ! Deviations from gamma angles
12576 !
12577         ugamma_i=0.0d0
12578         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
12579           dgamma_i=pinorm(phi(j)-phiref(j))
12580 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
12581           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
12582           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
12583 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
12584         enddo
12585         ugamma(i)=ugamma_i/(ii-2)
12586 !
12587 ! Deviations from local SC geometry
12588 !
12589         uscdiff(i)=0.0d0
12590         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
12591           dxx=xxtab(j)-xxref(j)
12592           dyy=yytab(j)-yyref(j)
12593           dzz=zztab(j)-zzref(j)
12594           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
12595           do k=1,3
12596             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
12597              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
12598              (ii-1)
12599             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
12600              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
12601              (ii-1)
12602             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
12603            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
12604             /(ii-1)
12605           enddo
12606 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
12607 !     &      xxref(j),yyref(j),zzref(j)
12608         enddo
12609         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
12610 !        write (iout,*) i," uscdiff",uscdiff(i)
12611 !
12612 ! Put together deviations from local geometry
12613 !
12614         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
12615           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
12616 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
12617 !     &   " uconst_back",uconst_back
12618         utheta(i)=dsqrt(utheta(i))
12619         ugamma(i)=dsqrt(ugamma(i))
12620         uscdiff(i)=dsqrt(uscdiff(i))
12621       enddo
12622       return
12623       end subroutine Econstr_back
12624 !-----------------------------------------------------------------------------
12625 ! energy_p_new-sep_barrier.F
12626 !-----------------------------------------------------------------------------
12627       real(kind=8) function sscale(r)
12628 !      include "COMMON.SPLITELE"
12629       real(kind=8) :: r,gamm
12630       if(r.lt.r_cut-rlamb) then
12631         sscale=1.0d0
12632       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12633         gamm=(r-(r_cut-rlamb))/rlamb
12634         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12635       else
12636         sscale=0d0
12637       endif
12638       return
12639       end function sscale
12640       real(kind=8) function sscale_grad(r)
12641 !      include "COMMON.SPLITELE"
12642       real(kind=8) :: r,gamm
12643       if(r.lt.r_cut-rlamb) then
12644         sscale_grad=0.0d0
12645       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12646         gamm=(r-(r_cut-rlamb))/rlamb
12647         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
12648       else
12649         sscale_grad=0d0
12650       endif
12651       return
12652       end function sscale_grad
12653
12654 !!!!!!!!!! PBCSCALE
12655       real(kind=8) function sscale_ele(r)
12656 !      include "COMMON.SPLITELE"
12657       real(kind=8) :: r,gamm
12658       if(r.lt.r_cut_ele-rlamb_ele) then
12659         sscale_ele=1.0d0
12660       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12661         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12662         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12663       else
12664         sscale_ele=0d0
12665       endif
12666       return
12667       end function sscale_ele
12668
12669       real(kind=8)  function sscagrad_ele(r)
12670       real(kind=8) :: r,gamm
12671 !      include "COMMON.SPLITELE"
12672       if(r.lt.r_cut_ele-rlamb_ele) then
12673         sscagrad_ele=0.0d0
12674       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12675         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12676         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
12677       else
12678         sscagrad_ele=0.0d0
12679       endif
12680       return
12681       end function sscagrad_ele
12682       real(kind=8) function sscalelip(r)
12683       real(kind=8) r,gamm
12684         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
12685       return
12686       end function sscalelip
12687 !C-----------------------------------------------------------------------
12688       real(kind=8) function sscagradlip(r)
12689       real(kind=8) r,gamm
12690         sscagradlip=r*(6.0d0*r-6.0d0)
12691       return
12692       end function sscagradlip
12693
12694 !!!!!!!!!!!!!!!
12695 !-----------------------------------------------------------------------------
12696       subroutine elj_long(evdw)
12697 !
12698 ! This subroutine calculates the interaction energy of nonbonded side chains
12699 ! assuming the LJ potential of interaction.
12700 !
12701 !      implicit real*8 (a-h,o-z)
12702 !      include 'DIMENSIONS'
12703 !      include 'COMMON.GEO'
12704 !      include 'COMMON.VAR'
12705 !      include 'COMMON.LOCAL'
12706 !      include 'COMMON.CHAIN'
12707 !      include 'COMMON.DERIV'
12708 !      include 'COMMON.INTERACT'
12709 !      include 'COMMON.TORSION'
12710 !      include 'COMMON.SBRIDGE'
12711 !      include 'COMMON.NAMES'
12712 !      include 'COMMON.IOUNITS'
12713 !      include 'COMMON.CONTACTS'
12714       real(kind=8),parameter :: accur=1.0d-10
12715       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12716 !el local variables
12717       integer :: i,iint,j,k,itypi,itypi1,itypj
12718       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12719       real(kind=8) :: e1,e2,evdwij,evdw
12720 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12721       evdw=0.0D0
12722       do i=iatsc_s,iatsc_e
12723         itypi=itype(i,1)
12724         if (itypi.eq.ntyp1) cycle
12725         itypi1=itype(i+1,1)
12726         xi=c(1,nres+i)
12727         yi=c(2,nres+i)
12728         zi=c(3,nres+i)
12729 !
12730 ! Calculate SC interaction energy.
12731 !
12732         do iint=1,nint_gr(i)
12733 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12734 !d   &                  'iend=',iend(i,iint)
12735           do j=istart(i,iint),iend(i,iint)
12736             itypj=itype(j,1)
12737             if (itypj.eq.ntyp1) cycle
12738             xj=c(1,nres+j)-xi
12739             yj=c(2,nres+j)-yi
12740             zj=c(3,nres+j)-zi
12741             rij=xj*xj+yj*yj+zj*zj
12742             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12743             if (sss.lt.1.0d0) then
12744               rrij=1.0D0/rij
12745               eps0ij=eps(itypi,itypj)
12746               fac=rrij**expon2
12747               e1=fac*fac*aa_aq(itypi,itypj)
12748               e2=fac*bb_aq(itypi,itypj)
12749               evdwij=e1+e2
12750               evdw=evdw+(1.0d0-sss)*evdwij
12751 !
12752 ! Calculate the components of the gradient in DC and X
12753 !
12754               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12755               gg(1)=xj*fac
12756               gg(2)=yj*fac
12757               gg(3)=zj*fac
12758               do k=1,3
12759                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12760                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12761                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12762                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12763               enddo
12764             endif
12765           enddo      ! j
12766         enddo        ! iint
12767       enddo          ! i
12768       do i=1,nct
12769         do j=1,3
12770           gvdwc(j,i)=expon*gvdwc(j,i)
12771           gvdwx(j,i)=expon*gvdwx(j,i)
12772         enddo
12773       enddo
12774 !******************************************************************************
12775 !
12776 !                              N O T E !!!
12777 !
12778 ! To save time, the factor of EXPON has been extracted from ALL components
12779 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12780 ! use!
12781 !
12782 !******************************************************************************
12783       return
12784       end subroutine elj_long
12785 !-----------------------------------------------------------------------------
12786       subroutine elj_short(evdw)
12787 !
12788 ! This subroutine calculates the interaction energy of nonbonded side chains
12789 ! assuming the LJ potential of interaction.
12790 !
12791 !      implicit real*8 (a-h,o-z)
12792 !      include 'DIMENSIONS'
12793 !      include 'COMMON.GEO'
12794 !      include 'COMMON.VAR'
12795 !      include 'COMMON.LOCAL'
12796 !      include 'COMMON.CHAIN'
12797 !      include 'COMMON.DERIV'
12798 !      include 'COMMON.INTERACT'
12799 !      include 'COMMON.TORSION'
12800 !      include 'COMMON.SBRIDGE'
12801 !      include 'COMMON.NAMES'
12802 !      include 'COMMON.IOUNITS'
12803 !      include 'COMMON.CONTACTS'
12804       real(kind=8),parameter :: accur=1.0d-10
12805       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12806 !el local variables
12807       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12808       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12809       real(kind=8) :: e1,e2,evdwij,evdw
12810 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12811       evdw=0.0D0
12812       do i=iatsc_s,iatsc_e
12813         itypi=itype(i,1)
12814         if (itypi.eq.ntyp1) cycle
12815         itypi1=itype(i+1,1)
12816         xi=c(1,nres+i)
12817         yi=c(2,nres+i)
12818         zi=c(3,nres+i)
12819 ! Change 12/1/95
12820         num_conti=0
12821 !
12822 ! Calculate SC interaction energy.
12823 !
12824         do iint=1,nint_gr(i)
12825 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12826 !d   &                  'iend=',iend(i,iint)
12827           do j=istart(i,iint),iend(i,iint)
12828             itypj=itype(j,1)
12829             if (itypj.eq.ntyp1) cycle
12830             xj=c(1,nres+j)-xi
12831             yj=c(2,nres+j)-yi
12832             zj=c(3,nres+j)-zi
12833 ! Change 12/1/95 to calculate four-body interactions
12834             rij=xj*xj+yj*yj+zj*zj
12835             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12836             if (sss.gt.0.0d0) then
12837               rrij=1.0D0/rij
12838               eps0ij=eps(itypi,itypj)
12839               fac=rrij**expon2
12840               e1=fac*fac*aa_aq(itypi,itypj)
12841               e2=fac*bb_aq(itypi,itypj)
12842               evdwij=e1+e2
12843               evdw=evdw+sss*evdwij
12844 !
12845 ! Calculate the components of the gradient in DC and X
12846 !
12847               fac=-rrij*(e1+evdwij)*sss
12848               gg(1)=xj*fac
12849               gg(2)=yj*fac
12850               gg(3)=zj*fac
12851               do k=1,3
12852                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12853                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12854                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12855                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12856               enddo
12857             endif
12858           enddo      ! j
12859         enddo        ! iint
12860       enddo          ! i
12861       do i=1,nct
12862         do j=1,3
12863           gvdwc(j,i)=expon*gvdwc(j,i)
12864           gvdwx(j,i)=expon*gvdwx(j,i)
12865         enddo
12866       enddo
12867 !******************************************************************************
12868 !
12869 !                              N O T E !!!
12870 !
12871 ! To save time, the factor of EXPON has been extracted from ALL components
12872 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12873 ! use!
12874 !
12875 !******************************************************************************
12876       return
12877       end subroutine elj_short
12878 !-----------------------------------------------------------------------------
12879       subroutine eljk_long(evdw)
12880 !
12881 ! This subroutine calculates the interaction energy of nonbonded side chains
12882 ! assuming the LJK potential of interaction.
12883 !
12884 !      implicit real*8 (a-h,o-z)
12885 !      include 'DIMENSIONS'
12886 !      include 'COMMON.GEO'
12887 !      include 'COMMON.VAR'
12888 !      include 'COMMON.LOCAL'
12889 !      include 'COMMON.CHAIN'
12890 !      include 'COMMON.DERIV'
12891 !      include 'COMMON.INTERACT'
12892 !      include 'COMMON.IOUNITS'
12893 !      include 'COMMON.NAMES'
12894       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12895       logical :: scheck
12896 !el local variables
12897       integer :: i,iint,j,k,itypi,itypi1,itypj
12898       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12899                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12900 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12901       evdw=0.0D0
12902       do i=iatsc_s,iatsc_e
12903         itypi=itype(i,1)
12904         if (itypi.eq.ntyp1) cycle
12905         itypi1=itype(i+1,1)
12906         xi=c(1,nres+i)
12907         yi=c(2,nres+i)
12908         zi=c(3,nres+i)
12909 !
12910 ! Calculate SC interaction energy.
12911 !
12912         do iint=1,nint_gr(i)
12913           do j=istart(i,iint),iend(i,iint)
12914             itypj=itype(j,1)
12915             if (itypj.eq.ntyp1) cycle
12916             xj=c(1,nres+j)-xi
12917             yj=c(2,nres+j)-yi
12918             zj=c(3,nres+j)-zi
12919             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12920             fac_augm=rrij**expon
12921             e_augm=augm(itypi,itypj)*fac_augm
12922             r_inv_ij=dsqrt(rrij)
12923             rij=1.0D0/r_inv_ij
12924             sss=sscale(rij/sigma(itypi,itypj))
12925             if (sss.lt.1.0d0) then
12926               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12927               fac=r_shift_inv**expon
12928               e1=fac*fac*aa_aq(itypi,itypj)
12929               e2=fac*bb_aq(itypi,itypj)
12930               evdwij=e_augm+e1+e2
12931 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12932 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12933 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12934 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12935 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12936 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12937 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12938               evdw=evdw+(1.0d0-sss)*evdwij
12939 !
12940 ! Calculate the components of the gradient in DC and X
12941 !
12942               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12943               fac=fac*(1.0d0-sss)
12944               gg(1)=xj*fac
12945               gg(2)=yj*fac
12946               gg(3)=zj*fac
12947               do k=1,3
12948                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12949                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12950                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12951                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12952               enddo
12953             endif
12954           enddo      ! j
12955         enddo        ! iint
12956       enddo          ! i
12957       do i=1,nct
12958         do j=1,3
12959           gvdwc(j,i)=expon*gvdwc(j,i)
12960           gvdwx(j,i)=expon*gvdwx(j,i)
12961         enddo
12962       enddo
12963       return
12964       end subroutine eljk_long
12965 !-----------------------------------------------------------------------------
12966       subroutine eljk_short(evdw)
12967 !
12968 ! This subroutine calculates the interaction energy of nonbonded side chains
12969 ! assuming the LJK potential of interaction.
12970 !
12971 !      implicit real*8 (a-h,o-z)
12972 !      include 'DIMENSIONS'
12973 !      include 'COMMON.GEO'
12974 !      include 'COMMON.VAR'
12975 !      include 'COMMON.LOCAL'
12976 !      include 'COMMON.CHAIN'
12977 !      include 'COMMON.DERIV'
12978 !      include 'COMMON.INTERACT'
12979 !      include 'COMMON.IOUNITS'
12980 !      include 'COMMON.NAMES'
12981       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12982       logical :: scheck
12983 !el local variables
12984       integer :: i,iint,j,k,itypi,itypi1,itypj
12985       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12986                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12987 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12988       evdw=0.0D0
12989       do i=iatsc_s,iatsc_e
12990         itypi=itype(i,1)
12991         if (itypi.eq.ntyp1) cycle
12992         itypi1=itype(i+1,1)
12993         xi=c(1,nres+i)
12994         yi=c(2,nres+i)
12995         zi=c(3,nres+i)
12996 !
12997 ! Calculate SC interaction energy.
12998 !
12999         do iint=1,nint_gr(i)
13000           do j=istart(i,iint),iend(i,iint)
13001             itypj=itype(j,1)
13002             if (itypj.eq.ntyp1) cycle
13003             xj=c(1,nres+j)-xi
13004             yj=c(2,nres+j)-yi
13005             zj=c(3,nres+j)-zi
13006             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13007             fac_augm=rrij**expon
13008             e_augm=augm(itypi,itypj)*fac_augm
13009             r_inv_ij=dsqrt(rrij)
13010             rij=1.0D0/r_inv_ij
13011             sss=sscale(rij/sigma(itypi,itypj))
13012             if (sss.gt.0.0d0) then
13013               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
13014               fac=r_shift_inv**expon
13015               e1=fac*fac*aa_aq(itypi,itypj)
13016               e2=fac*bb_aq(itypi,itypj)
13017               evdwij=e_augm+e1+e2
13018 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
13019 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
13020 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
13021 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
13022 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
13023 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
13024 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
13025               evdw=evdw+sss*evdwij
13026 !
13027 ! Calculate the components of the gradient in DC and X
13028 !
13029               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
13030               fac=fac*sss
13031               gg(1)=xj*fac
13032               gg(2)=yj*fac
13033               gg(3)=zj*fac
13034               do k=1,3
13035                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
13036                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
13037                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
13038                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
13039               enddo
13040             endif
13041           enddo      ! j
13042         enddo        ! iint
13043       enddo          ! i
13044       do i=1,nct
13045         do j=1,3
13046           gvdwc(j,i)=expon*gvdwc(j,i)
13047           gvdwx(j,i)=expon*gvdwx(j,i)
13048         enddo
13049       enddo
13050       return
13051       end subroutine eljk_short
13052 !-----------------------------------------------------------------------------
13053       subroutine ebp_long(evdw)
13054 !
13055 ! This subroutine calculates the interaction energy of nonbonded side chains
13056 ! assuming the Berne-Pechukas potential of interaction.
13057 !
13058       use calc_data
13059 !      implicit real*8 (a-h,o-z)
13060 !      include 'DIMENSIONS'
13061 !      include 'COMMON.GEO'
13062 !      include 'COMMON.VAR'
13063 !      include 'COMMON.LOCAL'
13064 !      include 'COMMON.CHAIN'
13065 !      include 'COMMON.DERIV'
13066 !      include 'COMMON.NAMES'
13067 !      include 'COMMON.INTERACT'
13068 !      include 'COMMON.IOUNITS'
13069 !      include 'COMMON.CALC'
13070       use comm_srutu
13071 !el      integer :: icall
13072 !el      common /srutu/ icall
13073 !     double precision rrsave(maxdim)
13074       logical :: lprn
13075 !el local variables
13076       integer :: iint,itypi,itypi1,itypj
13077       real(kind=8) :: rrij,xi,yi,zi,fac
13078       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
13079       evdw=0.0D0
13080 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13081       evdw=0.0D0
13082 !     if (icall.eq.0) then
13083 !       lprn=.true.
13084 !     else
13085         lprn=.false.
13086 !     endif
13087 !el      ind=0
13088       do i=iatsc_s,iatsc_e
13089         itypi=itype(i,1)
13090         if (itypi.eq.ntyp1) cycle
13091         itypi1=itype(i+1,1)
13092         xi=c(1,nres+i)
13093         yi=c(2,nres+i)
13094         zi=c(3,nres+i)
13095         dxi=dc_norm(1,nres+i)
13096         dyi=dc_norm(2,nres+i)
13097         dzi=dc_norm(3,nres+i)
13098 !        dsci_inv=dsc_inv(itypi)
13099         dsci_inv=vbld_inv(i+nres)
13100 !
13101 ! Calculate SC interaction energy.
13102 !
13103         do iint=1,nint_gr(i)
13104           do j=istart(i,iint),iend(i,iint)
13105 !el            ind=ind+1
13106             itypj=itype(j,1)
13107             if (itypj.eq.ntyp1) cycle
13108 !            dscj_inv=dsc_inv(itypj)
13109             dscj_inv=vbld_inv(j+nres)
13110             chi1=chi(itypi,itypj)
13111             chi2=chi(itypj,itypi)
13112             chi12=chi1*chi2
13113             chip1=chip(itypi)
13114             chip2=chip(itypj)
13115             chip12=chip1*chip2
13116             alf1=alp(itypi)
13117             alf2=alp(itypj)
13118             alf12=0.5D0*(alf1+alf2)
13119             xj=c(1,nres+j)-xi
13120             yj=c(2,nres+j)-yi
13121             zj=c(3,nres+j)-zi
13122             dxj=dc_norm(1,nres+j)
13123             dyj=dc_norm(2,nres+j)
13124             dzj=dc_norm(3,nres+j)
13125             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13126             rij=dsqrt(rrij)
13127             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13128
13129             if (sss.lt.1.0d0) then
13130
13131 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13132               call sc_angular
13133 ! Calculate whole angle-dependent part of epsilon and contributions
13134 ! to its derivatives
13135               fac=(rrij*sigsq)**expon2
13136               e1=fac*fac*aa_aq(itypi,itypj)
13137               e2=fac*bb_aq(itypi,itypj)
13138               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13139               eps2der=evdwij*eps3rt
13140               eps3der=evdwij*eps2rt
13141               evdwij=evdwij*eps2rt*eps3rt
13142               evdw=evdw+evdwij*(1.0d0-sss)
13143               if (lprn) then
13144               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13145               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13146 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13147 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13148 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13149 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13150 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13151 !d     &          evdwij
13152               endif
13153 ! Calculate gradient components.
13154               e1=e1*eps1*eps2rt**2*eps3rt**2
13155               fac=-expon*(e1+evdwij)
13156               sigder=fac/sigsq
13157               fac=rrij*fac
13158 ! Calculate radial part of the gradient
13159               gg(1)=xj*fac
13160               gg(2)=yj*fac
13161               gg(3)=zj*fac
13162 ! Calculate the angular part of the gradient and sum add the contributions
13163 ! to the appropriate components of the Cartesian gradient.
13164               call sc_grad_scale(1.0d0-sss)
13165             endif
13166           enddo      ! j
13167         enddo        ! iint
13168       enddo          ! i
13169 !     stop
13170       return
13171       end subroutine ebp_long
13172 !-----------------------------------------------------------------------------
13173       subroutine ebp_short(evdw)
13174 !
13175 ! This subroutine calculates the interaction energy of nonbonded side chains
13176 ! assuming the Berne-Pechukas potential of interaction.
13177 !
13178       use calc_data
13179 !      implicit real*8 (a-h,o-z)
13180 !      include 'DIMENSIONS'
13181 !      include 'COMMON.GEO'
13182 !      include 'COMMON.VAR'
13183 !      include 'COMMON.LOCAL'
13184 !      include 'COMMON.CHAIN'
13185 !      include 'COMMON.DERIV'
13186 !      include 'COMMON.NAMES'
13187 !      include 'COMMON.INTERACT'
13188 !      include 'COMMON.IOUNITS'
13189 !      include 'COMMON.CALC'
13190       use comm_srutu
13191 !el      integer :: icall
13192 !el      common /srutu/ icall
13193 !     double precision rrsave(maxdim)
13194       logical :: lprn
13195 !el local variables
13196       integer :: iint,itypi,itypi1,itypj
13197       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
13198       real(kind=8) :: sss,e1,e2,evdw
13199       evdw=0.0D0
13200 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13201       evdw=0.0D0
13202 !     if (icall.eq.0) then
13203 !       lprn=.true.
13204 !     else
13205         lprn=.false.
13206 !     endif
13207 !el      ind=0
13208       do i=iatsc_s,iatsc_e
13209         itypi=itype(i,1)
13210         if (itypi.eq.ntyp1) cycle
13211         itypi1=itype(i+1,1)
13212         xi=c(1,nres+i)
13213         yi=c(2,nres+i)
13214         zi=c(3,nres+i)
13215         dxi=dc_norm(1,nres+i)
13216         dyi=dc_norm(2,nres+i)
13217         dzi=dc_norm(3,nres+i)
13218 !        dsci_inv=dsc_inv(itypi)
13219         dsci_inv=vbld_inv(i+nres)
13220 !
13221 ! Calculate SC interaction energy.
13222 !
13223         do iint=1,nint_gr(i)
13224           do j=istart(i,iint),iend(i,iint)
13225 !el            ind=ind+1
13226             itypj=itype(j,1)
13227             if (itypj.eq.ntyp1) cycle
13228 !            dscj_inv=dsc_inv(itypj)
13229             dscj_inv=vbld_inv(j+nres)
13230             chi1=chi(itypi,itypj)
13231             chi2=chi(itypj,itypi)
13232             chi12=chi1*chi2
13233             chip1=chip(itypi)
13234             chip2=chip(itypj)
13235             chip12=chip1*chip2
13236             alf1=alp(itypi)
13237             alf2=alp(itypj)
13238             alf12=0.5D0*(alf1+alf2)
13239             xj=c(1,nres+j)-xi
13240             yj=c(2,nres+j)-yi
13241             zj=c(3,nres+j)-zi
13242             dxj=dc_norm(1,nres+j)
13243             dyj=dc_norm(2,nres+j)
13244             dzj=dc_norm(3,nres+j)
13245             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13246             rij=dsqrt(rrij)
13247             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13248
13249             if (sss.gt.0.0d0) then
13250
13251 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13252               call sc_angular
13253 ! Calculate whole angle-dependent part of epsilon and contributions
13254 ! to its derivatives
13255               fac=(rrij*sigsq)**expon2
13256               e1=fac*fac*aa_aq(itypi,itypj)
13257               e2=fac*bb_aq(itypi,itypj)
13258               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13259               eps2der=evdwij*eps3rt
13260               eps3der=evdwij*eps2rt
13261               evdwij=evdwij*eps2rt*eps3rt
13262               evdw=evdw+evdwij*sss
13263               if (lprn) then
13264               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13265               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13266 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13267 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13268 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13269 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13270 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13271 !d     &          evdwij
13272               endif
13273 ! Calculate gradient components.
13274               e1=e1*eps1*eps2rt**2*eps3rt**2
13275               fac=-expon*(e1+evdwij)
13276               sigder=fac/sigsq
13277               fac=rrij*fac
13278 ! Calculate radial part of the gradient
13279               gg(1)=xj*fac
13280               gg(2)=yj*fac
13281               gg(3)=zj*fac
13282 ! Calculate the angular part of the gradient and sum add the contributions
13283 ! to the appropriate components of the Cartesian gradient.
13284               call sc_grad_scale(sss)
13285             endif
13286           enddo      ! j
13287         enddo        ! iint
13288       enddo          ! i
13289 !     stop
13290       return
13291       end subroutine ebp_short
13292 !-----------------------------------------------------------------------------
13293       subroutine egb_long(evdw)
13294 !
13295 ! This subroutine calculates the interaction energy of nonbonded side chains
13296 ! assuming the Gay-Berne potential of interaction.
13297 !
13298       use calc_data
13299 !      implicit real*8 (a-h,o-z)
13300 !      include 'DIMENSIONS'
13301 !      include 'COMMON.GEO'
13302 !      include 'COMMON.VAR'
13303 !      include 'COMMON.LOCAL'
13304 !      include 'COMMON.CHAIN'
13305 !      include 'COMMON.DERIV'
13306 !      include 'COMMON.NAMES'
13307 !      include 'COMMON.INTERACT'
13308 !      include 'COMMON.IOUNITS'
13309 !      include 'COMMON.CALC'
13310 !      include 'COMMON.CONTROL'
13311       logical :: lprn
13312 !el local variables
13313       integer :: iint,itypi,itypi1,itypj,subchap
13314       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13315       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13316       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13317                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13318                     ssgradlipi,ssgradlipj
13319
13320
13321       evdw=0.0D0
13322 !cccc      energy_dec=.false.
13323 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13324       evdw=0.0D0
13325       lprn=.false.
13326 !     if (icall.eq.0) lprn=.false.
13327 !el      ind=0
13328       do i=iatsc_s,iatsc_e
13329         itypi=itype(i,1)
13330         if (itypi.eq.ntyp1) cycle
13331         itypi1=itype(i+1,1)
13332         xi=c(1,nres+i)
13333         yi=c(2,nres+i)
13334         zi=c(3,nres+i)
13335           xi=mod(xi,boxxsize)
13336           if (xi.lt.0) xi=xi+boxxsize
13337           yi=mod(yi,boxysize)
13338           if (yi.lt.0) yi=yi+boxysize
13339           zi=mod(zi,boxzsize)
13340           if (zi.lt.0) zi=zi+boxzsize
13341        if ((zi.gt.bordlipbot)    &
13342         .and.(zi.lt.bordliptop)) then
13343 !C the energy transfer exist
13344         if (zi.lt.buflipbot) then
13345 !C what fraction I am in
13346          fracinbuf=1.0d0-    &
13347              ((zi-bordlipbot)/lipbufthick)
13348 !C lipbufthick is thickenes of lipid buffore
13349          sslipi=sscalelip(fracinbuf)
13350          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13351         elseif (zi.gt.bufliptop) then
13352          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13353          sslipi=sscalelip(fracinbuf)
13354          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13355         else
13356          sslipi=1.0d0
13357          ssgradlipi=0.0
13358         endif
13359        else
13360          sslipi=0.0d0
13361          ssgradlipi=0.0
13362        endif
13363
13364         dxi=dc_norm(1,nres+i)
13365         dyi=dc_norm(2,nres+i)
13366         dzi=dc_norm(3,nres+i)
13367 !        dsci_inv=dsc_inv(itypi)
13368         dsci_inv=vbld_inv(i+nres)
13369 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13370 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13371 !
13372 ! Calculate SC interaction energy.
13373 !
13374         do iint=1,nint_gr(i)
13375           do j=istart(i,iint),iend(i,iint)
13376             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13377 !              call dyn_ssbond_ene(i,j,evdwij)
13378 !              evdw=evdw+evdwij
13379 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13380 !                              'evdw',i,j,evdwij,' ss'
13381 !              if (energy_dec) write (iout,*) &
13382 !                              'evdw',i,j,evdwij,' ss'
13383 !             do k=j+1,iend(i,iint)
13384 !C search over all next residues
13385 !              if (dyn_ss_mask(k)) then
13386 !C check if they are cysteins
13387 !C              write(iout,*) 'k=',k
13388
13389 !c              write(iout,*) "PRZED TRI", evdwij
13390 !               evdwij_przed_tri=evdwij
13391 !              call triple_ssbond_ene(i,j,k,evdwij)
13392 !c               if(evdwij_przed_tri.ne.evdwij) then
13393 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13394 !c               endif
13395
13396 !c              write(iout,*) "PO TRI", evdwij
13397 !C call the energy function that removes the artifical triple disulfide
13398 !C bond the soubroutine is located in ssMD.F
13399 !              evdw=evdw+evdwij
13400               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13401                             'evdw',i,j,evdwij,'tss'
13402 !              endif!dyn_ss_mask(k)
13403 !             enddo! k
13404
13405             ELSE
13406 !el            ind=ind+1
13407             itypj=itype(j,1)
13408             if (itypj.eq.ntyp1) cycle
13409 !            dscj_inv=dsc_inv(itypj)
13410             dscj_inv=vbld_inv(j+nres)
13411 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13412 !     &       1.0d0/vbld(j+nres)
13413 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13414             sig0ij=sigma(itypi,itypj)
13415             chi1=chi(itypi,itypj)
13416             chi2=chi(itypj,itypi)
13417             chi12=chi1*chi2
13418             chip1=chip(itypi)
13419             chip2=chip(itypj)
13420             chip12=chip1*chip2
13421             alf1=alp(itypi)
13422             alf2=alp(itypj)
13423             alf12=0.5D0*(alf1+alf2)
13424             xj=c(1,nres+j)
13425             yj=c(2,nres+j)
13426             zj=c(3,nres+j)
13427 ! Searching for nearest neighbour
13428           xj=mod(xj,boxxsize)
13429           if (xj.lt.0) xj=xj+boxxsize
13430           yj=mod(yj,boxysize)
13431           if (yj.lt.0) yj=yj+boxysize
13432           zj=mod(zj,boxzsize)
13433           if (zj.lt.0) zj=zj+boxzsize
13434        if ((zj.gt.bordlipbot)   &
13435       .and.(zj.lt.bordliptop)) then
13436 !C the energy transfer exist
13437         if (zj.lt.buflipbot) then
13438 !C what fraction I am in
13439          fracinbuf=1.0d0-  &
13440              ((zj-bordlipbot)/lipbufthick)
13441 !C lipbufthick is thickenes of lipid buffore
13442          sslipj=sscalelip(fracinbuf)
13443          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13444         elseif (zj.gt.bufliptop) then
13445          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13446          sslipj=sscalelip(fracinbuf)
13447          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13448         else
13449          sslipj=1.0d0
13450          ssgradlipj=0.0
13451         endif
13452        else
13453          sslipj=0.0d0
13454          ssgradlipj=0.0
13455        endif
13456       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13457        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13458       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13459        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13460
13461           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13462           xj_safe=xj
13463           yj_safe=yj
13464           zj_safe=zj
13465           subchap=0
13466           do xshift=-1,1
13467           do yshift=-1,1
13468           do zshift=-1,1
13469           xj=xj_safe+xshift*boxxsize
13470           yj=yj_safe+yshift*boxysize
13471           zj=zj_safe+zshift*boxzsize
13472           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13473           if(dist_temp.lt.dist_init) then
13474             dist_init=dist_temp
13475             xj_temp=xj
13476             yj_temp=yj
13477             zj_temp=zj
13478             subchap=1
13479           endif
13480           enddo
13481           enddo
13482           enddo
13483           if (subchap.eq.1) then
13484           xj=xj_temp-xi
13485           yj=yj_temp-yi
13486           zj=zj_temp-zi
13487           else
13488           xj=xj_safe-xi
13489           yj=yj_safe-yi
13490           zj=zj_safe-zi
13491           endif
13492
13493             dxj=dc_norm(1,nres+j)
13494             dyj=dc_norm(2,nres+j)
13495             dzj=dc_norm(3,nres+j)
13496             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13497             rij=dsqrt(rrij)
13498             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13499             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13500             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13501             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13502             if (sss_ele_cut.le.0.0) cycle
13503             if (sss.lt.1.0d0) then
13504
13505 ! Calculate angle-dependent terms of energy and contributions to their
13506 ! derivatives.
13507               call sc_angular
13508               sigsq=1.0D0/sigsq
13509               sig=sig0ij*dsqrt(sigsq)
13510               rij_shift=1.0D0/rij-sig+sig0ij
13511 ! for diagnostics; uncomment
13512 !              rij_shift=1.2*sig0ij
13513 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13514               if (rij_shift.le.0.0D0) then
13515                 evdw=1.0D20
13516 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13517 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13518 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13519                 return
13520               endif
13521               sigder=-sig*sigsq
13522 !---------------------------------------------------------------
13523               rij_shift=1.0D0/rij_shift
13524               fac=rij_shift**expon
13525               e1=fac*fac*aa
13526               e2=fac*bb
13527               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13528               eps2der=evdwij*eps3rt
13529               eps3der=evdwij*eps2rt
13530 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13531 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13532               evdwij=evdwij*eps2rt*eps3rt
13533               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13534               if (lprn) then
13535               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13536               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13537               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13538                 restyp(itypi,1),i,restyp(itypj,1),j,&
13539                 epsi,sigm,chi1,chi2,chip1,chip2,&
13540                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13541                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13542                 evdwij
13543               endif
13544
13545               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13546                               'evdw',i,j,evdwij
13547 !              if (energy_dec) write (iout,*) &
13548 !                              'evdw',i,j,evdwij,"egb_long"
13549
13550 ! Calculate gradient components.
13551               e1=e1*eps1*eps2rt**2*eps3rt**2
13552               fac=-expon*(e1+evdwij)*rij_shift
13553               sigder=fac*sigder
13554               fac=rij*fac
13555               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13556             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
13557             /sigmaii(itypi,itypj))
13558 !              fac=0.0d0
13559 ! Calculate the radial part of the gradient
13560               gg(1)=xj*fac
13561               gg(2)=yj*fac
13562               gg(3)=zj*fac
13563 ! Calculate angular part of the gradient.
13564               call sc_grad_scale(1.0d0-sss)
13565             ENDIF    !mask_dyn_ss
13566             endif
13567           enddo      ! j
13568         enddo        ! iint
13569       enddo          ! i
13570 !      write (iout,*) "Number of loop steps in EGB:",ind
13571 !ccc      energy_dec=.false.
13572       return
13573       end subroutine egb_long
13574 !-----------------------------------------------------------------------------
13575       subroutine egb_short(evdw)
13576 !
13577 ! This subroutine calculates the interaction energy of nonbonded side chains
13578 ! assuming the Gay-Berne potential of interaction.
13579 !
13580       use calc_data
13581 !      implicit real*8 (a-h,o-z)
13582 !      include 'DIMENSIONS'
13583 !      include 'COMMON.GEO'
13584 !      include 'COMMON.VAR'
13585 !      include 'COMMON.LOCAL'
13586 !      include 'COMMON.CHAIN'
13587 !      include 'COMMON.DERIV'
13588 !      include 'COMMON.NAMES'
13589 !      include 'COMMON.INTERACT'
13590 !      include 'COMMON.IOUNITS'
13591 !      include 'COMMON.CALC'
13592 !      include 'COMMON.CONTROL'
13593       logical :: lprn
13594 !el local variables
13595       integer :: iint,itypi,itypi1,itypj,subchap
13596       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
13597       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
13598       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13599                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13600                     ssgradlipi,ssgradlipj
13601       evdw=0.0D0
13602 !cccc      energy_dec=.false.
13603 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13604       evdw=0.0D0
13605       lprn=.false.
13606 !     if (icall.eq.0) lprn=.false.
13607 !el      ind=0
13608       do i=iatsc_s,iatsc_e
13609         itypi=itype(i,1)
13610         if (itypi.eq.ntyp1) cycle
13611         itypi1=itype(i+1,1)
13612         xi=c(1,nres+i)
13613         yi=c(2,nres+i)
13614         zi=c(3,nres+i)
13615           xi=mod(xi,boxxsize)
13616           if (xi.lt.0) xi=xi+boxxsize
13617           yi=mod(yi,boxysize)
13618           if (yi.lt.0) yi=yi+boxysize
13619           zi=mod(zi,boxzsize)
13620           if (zi.lt.0) zi=zi+boxzsize
13621        if ((zi.gt.bordlipbot)    &
13622         .and.(zi.lt.bordliptop)) then
13623 !C the energy transfer exist
13624         if (zi.lt.buflipbot) then
13625 !C what fraction I am in
13626          fracinbuf=1.0d0-    &
13627              ((zi-bordlipbot)/lipbufthick)
13628 !C lipbufthick is thickenes of lipid buffore
13629          sslipi=sscalelip(fracinbuf)
13630          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13631         elseif (zi.gt.bufliptop) then
13632          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13633          sslipi=sscalelip(fracinbuf)
13634          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13635         else
13636          sslipi=1.0d0
13637          ssgradlipi=0.0
13638         endif
13639        else
13640          sslipi=0.0d0
13641          ssgradlipi=0.0
13642        endif
13643
13644         dxi=dc_norm(1,nres+i)
13645         dyi=dc_norm(2,nres+i)
13646         dzi=dc_norm(3,nres+i)
13647 !        dsci_inv=dsc_inv(itypi)
13648         dsci_inv=vbld_inv(i+nres)
13649
13650         dxi=dc_norm(1,nres+i)
13651         dyi=dc_norm(2,nres+i)
13652         dzi=dc_norm(3,nres+i)
13653 !        dsci_inv=dsc_inv(itypi)
13654         dsci_inv=vbld_inv(i+nres)
13655 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13656 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13657 !
13658 ! Calculate SC interaction energy.
13659 !
13660         do iint=1,nint_gr(i)
13661           do j=istart(i,iint),iend(i,iint)
13662             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13663               call dyn_ssbond_ene(i,j,evdwij)
13664               evdw=evdw+evdwij
13665               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13666                               'evdw',i,j,evdwij,' ss'
13667              do k=j+1,iend(i,iint)
13668 !C search over all next residues
13669               if (dyn_ss_mask(k)) then
13670 !C check if they are cysteins
13671 !C              write(iout,*) 'k=',k
13672
13673 !c              write(iout,*) "PRZED TRI", evdwij
13674 !               evdwij_przed_tri=evdwij
13675               call triple_ssbond_ene(i,j,k,evdwij)
13676 !c               if(evdwij_przed_tri.ne.evdwij) then
13677 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13678 !c               endif
13679
13680 !c              write(iout,*) "PO TRI", evdwij
13681 !C call the energy function that removes the artifical triple disulfide
13682 !C bond the soubroutine is located in ssMD.F
13683               evdw=evdw+evdwij
13684               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13685                             'evdw',i,j,evdwij,'tss'
13686               endif!dyn_ss_mask(k)
13687              enddo! k
13688
13689 !              if (energy_dec) write (iout,*) &
13690 !                              'evdw',i,j,evdwij,' ss'
13691             ELSE
13692 !el            ind=ind+1
13693             itypj=itype(j,1)
13694             if (itypj.eq.ntyp1) cycle
13695 !            dscj_inv=dsc_inv(itypj)
13696             dscj_inv=vbld_inv(j+nres)
13697 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13698 !     &       1.0d0/vbld(j+nres)
13699 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13700             sig0ij=sigma(itypi,itypj)
13701             chi1=chi(itypi,itypj)
13702             chi2=chi(itypj,itypi)
13703             chi12=chi1*chi2
13704             chip1=chip(itypi)
13705             chip2=chip(itypj)
13706             chip12=chip1*chip2
13707             alf1=alp(itypi)
13708             alf2=alp(itypj)
13709             alf12=0.5D0*(alf1+alf2)
13710 !            xj=c(1,nres+j)-xi
13711 !            yj=c(2,nres+j)-yi
13712 !            zj=c(3,nres+j)-zi
13713             xj=c(1,nres+j)
13714             yj=c(2,nres+j)
13715             zj=c(3,nres+j)
13716 ! Searching for nearest neighbour
13717           xj=mod(xj,boxxsize)
13718           if (xj.lt.0) xj=xj+boxxsize
13719           yj=mod(yj,boxysize)
13720           if (yj.lt.0) yj=yj+boxysize
13721           zj=mod(zj,boxzsize)
13722           if (zj.lt.0) zj=zj+boxzsize
13723        if ((zj.gt.bordlipbot)   &
13724       .and.(zj.lt.bordliptop)) then
13725 !C the energy transfer exist
13726         if (zj.lt.buflipbot) then
13727 !C what fraction I am in
13728          fracinbuf=1.0d0-  &
13729              ((zj-bordlipbot)/lipbufthick)
13730 !C lipbufthick is thickenes of lipid buffore
13731          sslipj=sscalelip(fracinbuf)
13732          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13733         elseif (zj.gt.bufliptop) then
13734          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13735          sslipj=sscalelip(fracinbuf)
13736          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13737         else
13738          sslipj=1.0d0
13739          ssgradlipj=0.0
13740         endif
13741        else
13742          sslipj=0.0d0
13743          ssgradlipj=0.0
13744        endif
13745       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13746        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13747       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13748        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13749
13750           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13751           xj_safe=xj
13752           yj_safe=yj
13753           zj_safe=zj
13754           subchap=0
13755
13756           do xshift=-1,1
13757           do yshift=-1,1
13758           do zshift=-1,1
13759           xj=xj_safe+xshift*boxxsize
13760           yj=yj_safe+yshift*boxysize
13761           zj=zj_safe+zshift*boxzsize
13762           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13763           if(dist_temp.lt.dist_init) then
13764             dist_init=dist_temp
13765             xj_temp=xj
13766             yj_temp=yj
13767             zj_temp=zj
13768             subchap=1
13769           endif
13770           enddo
13771           enddo
13772           enddo
13773           if (subchap.eq.1) then
13774           xj=xj_temp-xi
13775           yj=yj_temp-yi
13776           zj=zj_temp-zi
13777           else
13778           xj=xj_safe-xi
13779           yj=yj_safe-yi
13780           zj=zj_safe-zi
13781           endif
13782
13783             dxj=dc_norm(1,nres+j)
13784             dyj=dc_norm(2,nres+j)
13785             dzj=dc_norm(3,nres+j)
13786             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13787             rij=dsqrt(rrij)
13788             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13789             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13790             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13791             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13792             if (sss_ele_cut.le.0.0) cycle
13793
13794             if (sss.gt.0.0d0) then
13795
13796 ! Calculate angle-dependent terms of energy and contributions to their
13797 ! derivatives.
13798               call sc_angular
13799               sigsq=1.0D0/sigsq
13800               sig=sig0ij*dsqrt(sigsq)
13801               rij_shift=1.0D0/rij-sig+sig0ij
13802 ! for diagnostics; uncomment
13803 !              rij_shift=1.2*sig0ij
13804 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13805               if (rij_shift.le.0.0D0) then
13806                 evdw=1.0D20
13807 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13808 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13809 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13810                 return
13811               endif
13812               sigder=-sig*sigsq
13813 !---------------------------------------------------------------
13814               rij_shift=1.0D0/rij_shift
13815               fac=rij_shift**expon
13816               e1=fac*fac*aa
13817               e2=fac*bb
13818               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13819               eps2der=evdwij*eps3rt
13820               eps3der=evdwij*eps2rt
13821 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13822 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13823               evdwij=evdwij*eps2rt*eps3rt
13824               evdw=evdw+evdwij*sss*sss_ele_cut
13825               if (lprn) then
13826               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13827               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13828               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13829                 restyp(itypi,1),i,restyp(itypj,1),j,&
13830                 epsi,sigm,chi1,chi2,chip1,chip2,&
13831                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13832                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13833                 evdwij
13834               endif
13835
13836               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13837                               'evdw',i,j,evdwij
13838 !              if (energy_dec) write (iout,*) &
13839 !                              'evdw',i,j,evdwij,"egb_short"
13840
13841 ! Calculate gradient components.
13842               e1=e1*eps1*eps2rt**2*eps3rt**2
13843               fac=-expon*(e1+evdwij)*rij_shift
13844               sigder=fac*sigder
13845               fac=rij*fac
13846               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13847             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13848             /sigmaii(itypi,itypj))
13849
13850 !              fac=0.0d0
13851 ! Calculate the radial part of the gradient
13852               gg(1)=xj*fac
13853               gg(2)=yj*fac
13854               gg(3)=zj*fac
13855 ! Calculate angular part of the gradient.
13856               call sc_grad_scale(sss)
13857             endif
13858           ENDIF !mask_dyn_ss
13859           enddo      ! j
13860         enddo        ! iint
13861       enddo          ! i
13862 !      write (iout,*) "Number of loop steps in EGB:",ind
13863 !ccc      energy_dec=.false.
13864       return
13865       end subroutine egb_short
13866 !-----------------------------------------------------------------------------
13867       subroutine egbv_long(evdw)
13868 !
13869 ! This subroutine calculates the interaction energy of nonbonded side chains
13870 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13871 !
13872       use calc_data
13873 !      implicit real*8 (a-h,o-z)
13874 !      include 'DIMENSIONS'
13875 !      include 'COMMON.GEO'
13876 !      include 'COMMON.VAR'
13877 !      include 'COMMON.LOCAL'
13878 !      include 'COMMON.CHAIN'
13879 !      include 'COMMON.DERIV'
13880 !      include 'COMMON.NAMES'
13881 !      include 'COMMON.INTERACT'
13882 !      include 'COMMON.IOUNITS'
13883 !      include 'COMMON.CALC'
13884       use comm_srutu
13885 !el      integer :: icall
13886 !el      common /srutu/ icall
13887       logical :: lprn
13888 !el local variables
13889       integer :: iint,itypi,itypi1,itypj
13890       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13891       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13892       evdw=0.0D0
13893 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13894       evdw=0.0D0
13895       lprn=.false.
13896 !     if (icall.eq.0) lprn=.true.
13897 !el      ind=0
13898       do i=iatsc_s,iatsc_e
13899         itypi=itype(i,1)
13900         if (itypi.eq.ntyp1) cycle
13901         itypi1=itype(i+1,1)
13902         xi=c(1,nres+i)
13903         yi=c(2,nres+i)
13904         zi=c(3,nres+i)
13905         dxi=dc_norm(1,nres+i)
13906         dyi=dc_norm(2,nres+i)
13907         dzi=dc_norm(3,nres+i)
13908 !        dsci_inv=dsc_inv(itypi)
13909         dsci_inv=vbld_inv(i+nres)
13910 !
13911 ! Calculate SC interaction energy.
13912 !
13913         do iint=1,nint_gr(i)
13914           do j=istart(i,iint),iend(i,iint)
13915 !el            ind=ind+1
13916             itypj=itype(j,1)
13917             if (itypj.eq.ntyp1) cycle
13918 !            dscj_inv=dsc_inv(itypj)
13919             dscj_inv=vbld_inv(j+nres)
13920             sig0ij=sigma(itypi,itypj)
13921             r0ij=r0(itypi,itypj)
13922             chi1=chi(itypi,itypj)
13923             chi2=chi(itypj,itypi)
13924             chi12=chi1*chi2
13925             chip1=chip(itypi)
13926             chip2=chip(itypj)
13927             chip12=chip1*chip2
13928             alf1=alp(itypi)
13929             alf2=alp(itypj)
13930             alf12=0.5D0*(alf1+alf2)
13931             xj=c(1,nres+j)-xi
13932             yj=c(2,nres+j)-yi
13933             zj=c(3,nres+j)-zi
13934             dxj=dc_norm(1,nres+j)
13935             dyj=dc_norm(2,nres+j)
13936             dzj=dc_norm(3,nres+j)
13937             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13938             rij=dsqrt(rrij)
13939
13940             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13941
13942             if (sss.lt.1.0d0) then
13943
13944 ! Calculate angle-dependent terms of energy and contributions to their
13945 ! derivatives.
13946               call sc_angular
13947               sigsq=1.0D0/sigsq
13948               sig=sig0ij*dsqrt(sigsq)
13949               rij_shift=1.0D0/rij-sig+r0ij
13950 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13951               if (rij_shift.le.0.0D0) then
13952                 evdw=1.0D20
13953                 return
13954               endif
13955               sigder=-sig*sigsq
13956 !---------------------------------------------------------------
13957               rij_shift=1.0D0/rij_shift
13958               fac=rij_shift**expon
13959               e1=fac*fac*aa_aq(itypi,itypj)
13960               e2=fac*bb_aq(itypi,itypj)
13961               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13962               eps2der=evdwij*eps3rt
13963               eps3der=evdwij*eps2rt
13964               fac_augm=rrij**expon
13965               e_augm=augm(itypi,itypj)*fac_augm
13966               evdwij=evdwij*eps2rt*eps3rt
13967               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13968               if (lprn) then
13969               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13970               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13971               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13972                 restyp(itypi,1),i,restyp(itypj,1),j,&
13973                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13974                 chi1,chi2,chip1,chip2,&
13975                 eps1,eps2rt**2,eps3rt**2,&
13976                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13977                 evdwij+e_augm
13978               endif
13979 ! Calculate gradient components.
13980               e1=e1*eps1*eps2rt**2*eps3rt**2
13981               fac=-expon*(e1+evdwij)*rij_shift
13982               sigder=fac*sigder
13983               fac=rij*fac-2*expon*rrij*e_augm
13984 ! Calculate the radial part of the gradient
13985               gg(1)=xj*fac
13986               gg(2)=yj*fac
13987               gg(3)=zj*fac
13988 ! Calculate angular part of the gradient.
13989               call sc_grad_scale(1.0d0-sss)
13990             endif
13991           enddo      ! j
13992         enddo        ! iint
13993       enddo          ! i
13994       end subroutine egbv_long
13995 !-----------------------------------------------------------------------------
13996       subroutine egbv_short(evdw)
13997 !
13998 ! This subroutine calculates the interaction energy of nonbonded side chains
13999 ! assuming the Gay-Berne-Vorobjev potential of interaction.
14000 !
14001       use calc_data
14002 !      implicit real*8 (a-h,o-z)
14003 !      include 'DIMENSIONS'
14004 !      include 'COMMON.GEO'
14005 !      include 'COMMON.VAR'
14006 !      include 'COMMON.LOCAL'
14007 !      include 'COMMON.CHAIN'
14008 !      include 'COMMON.DERIV'
14009 !      include 'COMMON.NAMES'
14010 !      include 'COMMON.INTERACT'
14011 !      include 'COMMON.IOUNITS'
14012 !      include 'COMMON.CALC'
14013       use comm_srutu
14014 !el      integer :: icall
14015 !el      common /srutu/ icall
14016       logical :: lprn
14017 !el local variables
14018       integer :: iint,itypi,itypi1,itypj
14019       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
14020       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
14021       evdw=0.0D0
14022 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
14023       evdw=0.0D0
14024       lprn=.false.
14025 !     if (icall.eq.0) lprn=.true.
14026 !el      ind=0
14027       do i=iatsc_s,iatsc_e
14028         itypi=itype(i,1)
14029         if (itypi.eq.ntyp1) cycle
14030         itypi1=itype(i+1,1)
14031         xi=c(1,nres+i)
14032         yi=c(2,nres+i)
14033         zi=c(3,nres+i)
14034         dxi=dc_norm(1,nres+i)
14035         dyi=dc_norm(2,nres+i)
14036         dzi=dc_norm(3,nres+i)
14037 !        dsci_inv=dsc_inv(itypi)
14038         dsci_inv=vbld_inv(i+nres)
14039 !
14040 ! Calculate SC interaction energy.
14041 !
14042         do iint=1,nint_gr(i)
14043           do j=istart(i,iint),iend(i,iint)
14044 !el            ind=ind+1
14045             itypj=itype(j,1)
14046             if (itypj.eq.ntyp1) cycle
14047 !            dscj_inv=dsc_inv(itypj)
14048             dscj_inv=vbld_inv(j+nres)
14049             sig0ij=sigma(itypi,itypj)
14050             r0ij=r0(itypi,itypj)
14051             chi1=chi(itypi,itypj)
14052             chi2=chi(itypj,itypi)
14053             chi12=chi1*chi2
14054             chip1=chip(itypi)
14055             chip2=chip(itypj)
14056             chip12=chip1*chip2
14057             alf1=alp(itypi)
14058             alf2=alp(itypj)
14059             alf12=0.5D0*(alf1+alf2)
14060             xj=c(1,nres+j)-xi
14061             yj=c(2,nres+j)-yi
14062             zj=c(3,nres+j)-zi
14063             dxj=dc_norm(1,nres+j)
14064             dyj=dc_norm(2,nres+j)
14065             dzj=dc_norm(3,nres+j)
14066             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
14067             rij=dsqrt(rrij)
14068
14069             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
14070
14071             if (sss.gt.0.0d0) then
14072
14073 ! Calculate angle-dependent terms of energy and contributions to their
14074 ! derivatives.
14075               call sc_angular
14076               sigsq=1.0D0/sigsq
14077               sig=sig0ij*dsqrt(sigsq)
14078               rij_shift=1.0D0/rij-sig+r0ij
14079 ! I hate to put IF's in the loops, but here don't have another choice!!!!
14080               if (rij_shift.le.0.0D0) then
14081                 evdw=1.0D20
14082                 return
14083               endif
14084               sigder=-sig*sigsq
14085 !---------------------------------------------------------------
14086               rij_shift=1.0D0/rij_shift
14087               fac=rij_shift**expon
14088               e1=fac*fac*aa_aq(itypi,itypj)
14089               e2=fac*bb_aq(itypi,itypj)
14090               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
14091               eps2der=evdwij*eps3rt
14092               eps3der=evdwij*eps2rt
14093               fac_augm=rrij**expon
14094               e_augm=augm(itypi,itypj)*fac_augm
14095               evdwij=evdwij*eps2rt*eps3rt
14096               evdw=evdw+(evdwij+e_augm)*sss
14097               if (lprn) then
14098               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
14099               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
14100               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
14101                 restyp(itypi,1),i,restyp(itypj,1),j,&
14102                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
14103                 chi1,chi2,chip1,chip2,&
14104                 eps1,eps2rt**2,eps3rt**2,&
14105                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
14106                 evdwij+e_augm
14107               endif
14108 ! Calculate gradient components.
14109               e1=e1*eps1*eps2rt**2*eps3rt**2
14110               fac=-expon*(e1+evdwij)*rij_shift
14111               sigder=fac*sigder
14112               fac=rij*fac-2*expon*rrij*e_augm
14113 ! Calculate the radial part of the gradient
14114               gg(1)=xj*fac
14115               gg(2)=yj*fac
14116               gg(3)=zj*fac
14117 ! Calculate angular part of the gradient.
14118               call sc_grad_scale(sss)
14119             endif
14120           enddo      ! j
14121         enddo        ! iint
14122       enddo          ! i
14123       end subroutine egbv_short
14124 !-----------------------------------------------------------------------------
14125       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
14126 !
14127 ! This subroutine calculates the average interaction energy and its gradient
14128 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
14129 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
14130 ! The potential depends both on the distance of peptide-group centers and on
14131 ! the orientation of the CA-CA virtual bonds.
14132 !
14133 !      implicit real*8 (a-h,o-z)
14134
14135       use comm_locel
14136 #ifdef MPI
14137       include 'mpif.h'
14138 #endif
14139 !      include 'DIMENSIONS'
14140 !      include 'COMMON.CONTROL'
14141 !      include 'COMMON.SETUP'
14142 !      include 'COMMON.IOUNITS'
14143 !      include 'COMMON.GEO'
14144 !      include 'COMMON.VAR'
14145 !      include 'COMMON.LOCAL'
14146 !      include 'COMMON.CHAIN'
14147 !      include 'COMMON.DERIV'
14148 !      include 'COMMON.INTERACT'
14149 !      include 'COMMON.CONTACTS'
14150 !      include 'COMMON.TORSION'
14151 !      include 'COMMON.VECTORS'
14152 !      include 'COMMON.FFIELD'
14153 !      include 'COMMON.TIME1'
14154       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
14155       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
14156       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14157 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14158       real(kind=8),dimension(4) :: muij
14159 !el      integer :: num_conti,j1,j2
14160 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14161 !el                   dz_normi,xmedi,ymedi,zmedi
14162 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14163 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14164 !el          num_conti,j1,j2
14165 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14166 #ifdef MOMENT
14167       real(kind=8) :: scal_el=1.0d0
14168 #else
14169       real(kind=8) :: scal_el=0.5d0
14170 #endif
14171 ! 12/13/98
14172 ! 13-go grudnia roku pamietnego...
14173       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14174                                              0.0d0,1.0d0,0.0d0,&
14175                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14176 !el local variables
14177       integer :: i,j,k
14178       real(kind=8) :: fac
14179       real(kind=8) :: dxj,dyj,dzj
14180       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
14181
14182 !      allocate(num_cont_hb(nres)) !(maxres)
14183 !d      write(iout,*) 'In EELEC'
14184 !d      do i=1,nloctyp
14185 !d        write(iout,*) 'Type',i
14186 !d        write(iout,*) 'B1',B1(:,i)
14187 !d        write(iout,*) 'B2',B2(:,i)
14188 !d        write(iout,*) 'CC',CC(:,:,i)
14189 !d        write(iout,*) 'DD',DD(:,:,i)
14190 !d        write(iout,*) 'EE',EE(:,:,i)
14191 !d      enddo
14192 !d      call check_vecgrad
14193 !d      stop
14194       if (icheckgrad.eq.1) then
14195         do i=1,nres-1
14196           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
14197           do k=1,3
14198             dc_norm(k,i)=dc(k,i)*fac
14199           enddo
14200 !          write (iout,*) 'i',i,' fac',fac
14201         enddo
14202       endif
14203       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14204           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
14205           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
14206 !        call vec_and_deriv
14207 #ifdef TIMING
14208         time01=MPI_Wtime()
14209 #endif
14210 !        print *, "before set matrices"
14211         call set_matrices
14212 !        print *,"after set martices"
14213 #ifdef TIMING
14214         time_mat=time_mat+MPI_Wtime()-time01
14215 #endif
14216       endif
14217 !d      do i=1,nres-1
14218 !d        write (iout,*) 'i=',i
14219 !d        do k=1,3
14220 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14221 !d        enddo
14222 !d        do k=1,3
14223 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14224 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14225 !d        enddo
14226 !d      enddo
14227       t_eelecij=0.0d0
14228       ees=0.0D0
14229       evdw1=0.0D0
14230       eel_loc=0.0d0
14231       eello_turn3=0.0d0
14232       eello_turn4=0.0d0
14233 !el      ind=0
14234       do i=1,nres
14235         num_cont_hb(i)=0
14236       enddo
14237 !d      print '(a)','Enter EELEC'
14238 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14239 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14240 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14241       do i=1,nres
14242         gel_loc_loc(i)=0.0d0
14243         gcorr_loc(i)=0.0d0
14244       enddo
14245 !
14246 !
14247 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14248 !
14249 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14250 !
14251       do i=iturn3_start,iturn3_end
14252         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14253         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14254         dxi=dc(1,i)
14255         dyi=dc(2,i)
14256         dzi=dc(3,i)
14257         dx_normi=dc_norm(1,i)
14258         dy_normi=dc_norm(2,i)
14259         dz_normi=dc_norm(3,i)
14260         xmedi=c(1,i)+0.5d0*dxi
14261         ymedi=c(2,i)+0.5d0*dyi
14262         zmedi=c(3,i)+0.5d0*dzi
14263           xmedi=dmod(xmedi,boxxsize)
14264           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14265           ymedi=dmod(ymedi,boxysize)
14266           if (ymedi.lt.0) ymedi=ymedi+boxysize
14267           zmedi=dmod(zmedi,boxzsize)
14268           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14269         num_conti=0
14270         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14271         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14272         num_cont_hb(i)=num_conti
14273       enddo
14274       do i=iturn4_start,iturn4_end
14275         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14276           .or. itype(i+3,1).eq.ntyp1 &
14277           .or. itype(i+4,1).eq.ntyp1) cycle
14278         dxi=dc(1,i)
14279         dyi=dc(2,i)
14280         dzi=dc(3,i)
14281         dx_normi=dc_norm(1,i)
14282         dy_normi=dc_norm(2,i)
14283         dz_normi=dc_norm(3,i)
14284         xmedi=c(1,i)+0.5d0*dxi
14285         ymedi=c(2,i)+0.5d0*dyi
14286         zmedi=c(3,i)+0.5d0*dzi
14287           xmedi=dmod(xmedi,boxxsize)
14288           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14289           ymedi=dmod(ymedi,boxysize)
14290           if (ymedi.lt.0) ymedi=ymedi+boxysize
14291           zmedi=dmod(zmedi,boxzsize)
14292           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14293         num_conti=num_cont_hb(i)
14294         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14295         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14296           call eturn4(i,eello_turn4)
14297         num_cont_hb(i)=num_conti
14298       enddo   ! i
14299 !
14300 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14301 !
14302       do i=iatel_s,iatel_e
14303         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14304         dxi=dc(1,i)
14305         dyi=dc(2,i)
14306         dzi=dc(3,i)
14307         dx_normi=dc_norm(1,i)
14308         dy_normi=dc_norm(2,i)
14309         dz_normi=dc_norm(3,i)
14310         xmedi=c(1,i)+0.5d0*dxi
14311         ymedi=c(2,i)+0.5d0*dyi
14312         zmedi=c(3,i)+0.5d0*dzi
14313           xmedi=dmod(xmedi,boxxsize)
14314           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14315           ymedi=dmod(ymedi,boxysize)
14316           if (ymedi.lt.0) ymedi=ymedi+boxysize
14317           zmedi=dmod(zmedi,boxzsize)
14318           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14319 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14320         num_conti=num_cont_hb(i)
14321         do j=ielstart(i),ielend(i)
14322           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14323           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14324         enddo ! j
14325         num_cont_hb(i)=num_conti
14326       enddo   ! i
14327 !      write (iout,*) "Number of loop steps in EELEC:",ind
14328 !d      do i=1,nres
14329 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14330 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14331 !d      enddo
14332 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14333 !cc      eel_loc=eel_loc+eello_turn3
14334 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14335       return
14336       end subroutine eelec_scale
14337 !-----------------------------------------------------------------------------
14338       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14339 !      implicit real*8 (a-h,o-z)
14340
14341       use comm_locel
14342 !      include 'DIMENSIONS'
14343 #ifdef MPI
14344       include "mpif.h"
14345 #endif
14346 !      include 'COMMON.CONTROL'
14347 !      include 'COMMON.IOUNITS'
14348 !      include 'COMMON.GEO'
14349 !      include 'COMMON.VAR'
14350 !      include 'COMMON.LOCAL'
14351 !      include 'COMMON.CHAIN'
14352 !      include 'COMMON.DERIV'
14353 !      include 'COMMON.INTERACT'
14354 !      include 'COMMON.CONTACTS'
14355 !      include 'COMMON.TORSION'
14356 !      include 'COMMON.VECTORS'
14357 !      include 'COMMON.FFIELD'
14358 !      include 'COMMON.TIME1'
14359       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14360       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14361       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14362 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14363       real(kind=8),dimension(4) :: muij
14364       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14365                     dist_temp, dist_init,sss_grad
14366       integer xshift,yshift,zshift
14367
14368 !el      integer :: num_conti,j1,j2
14369 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14370 !el                   dz_normi,xmedi,ymedi,zmedi
14371 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14372 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14373 !el          num_conti,j1,j2
14374 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14375 #ifdef MOMENT
14376       real(kind=8) :: scal_el=1.0d0
14377 #else
14378       real(kind=8) :: scal_el=0.5d0
14379 #endif
14380 ! 12/13/98
14381 ! 13-go grudnia roku pamietnego...
14382       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14383                                              0.0d0,1.0d0,0.0d0,&
14384                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14385 !el local variables
14386       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14387       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14388       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14389       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14390       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14391       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14392       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14393                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14394                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14395                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14396                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14397                   ecosam,ecosbm,ecosgm,ghalf,time00
14398 !      integer :: maxconts
14399 !      maxconts = nres/4
14400 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14401 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14402 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14403 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14404 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14405 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14406 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14407 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14408 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14409 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14410 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14411 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14412 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14413
14414 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14415 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14416
14417 #ifdef MPI
14418           time00=MPI_Wtime()
14419 #endif
14420 !d      write (iout,*) "eelecij",i,j
14421 !el          ind=ind+1
14422           iteli=itel(i)
14423           itelj=itel(j)
14424           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14425           aaa=app(iteli,itelj)
14426           bbb=bpp(iteli,itelj)
14427           ael6i=ael6(iteli,itelj)
14428           ael3i=ael3(iteli,itelj)
14429           dxj=dc(1,j)
14430           dyj=dc(2,j)
14431           dzj=dc(3,j)
14432           dx_normj=dc_norm(1,j)
14433           dy_normj=dc_norm(2,j)
14434           dz_normj=dc_norm(3,j)
14435 !          xj=c(1,j)+0.5D0*dxj-xmedi
14436 !          yj=c(2,j)+0.5D0*dyj-ymedi
14437 !          zj=c(3,j)+0.5D0*dzj-zmedi
14438           xj=c(1,j)+0.5D0*dxj
14439           yj=c(2,j)+0.5D0*dyj
14440           zj=c(3,j)+0.5D0*dzj
14441           xj=mod(xj,boxxsize)
14442           if (xj.lt.0) xj=xj+boxxsize
14443           yj=mod(yj,boxysize)
14444           if (yj.lt.0) yj=yj+boxysize
14445           zj=mod(zj,boxzsize)
14446           if (zj.lt.0) zj=zj+boxzsize
14447       isubchap=0
14448       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14449       xj_safe=xj
14450       yj_safe=yj
14451       zj_safe=zj
14452       do xshift=-1,1
14453       do yshift=-1,1
14454       do zshift=-1,1
14455           xj=xj_safe+xshift*boxxsize
14456           yj=yj_safe+yshift*boxysize
14457           zj=zj_safe+zshift*boxzsize
14458           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14459           if(dist_temp.lt.dist_init) then
14460             dist_init=dist_temp
14461             xj_temp=xj
14462             yj_temp=yj
14463             zj_temp=zj
14464             isubchap=1
14465           endif
14466        enddo
14467        enddo
14468        enddo
14469        if (isubchap.eq.1) then
14470 !C          print *,i,j
14471           xj=xj_temp-xmedi
14472           yj=yj_temp-ymedi
14473           zj=zj_temp-zmedi
14474        else
14475           xj=xj_safe-xmedi
14476           yj=yj_safe-ymedi
14477           zj=zj_safe-zmedi
14478        endif
14479
14480           rij=xj*xj+yj*yj+zj*zj
14481           rrmij=1.0D0/rij
14482           rij=dsqrt(rij)
14483           rmij=1.0D0/rij
14484 ! For extracting the short-range part of Evdwpp
14485           sss=sscale(rij/rpp(iteli,itelj))
14486             sss_ele_cut=sscale_ele(rij)
14487             sss_ele_grad=sscagrad_ele(rij)
14488             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14489 !             sss_ele_cut=1.0d0
14490 !             sss_ele_grad=0.0d0
14491             if (sss_ele_cut.le.0.0) go to 128
14492
14493           r3ij=rrmij*rmij
14494           r6ij=r3ij*r3ij
14495           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14496           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14497           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14498           fac=cosa-3.0D0*cosb*cosg
14499           ev1=aaa*r6ij*r6ij
14500 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14501           if (j.eq.i+2) ev1=scal_el*ev1
14502           ev2=bbb*r6ij
14503           fac3=ael6i*r6ij
14504           fac4=ael3i*r3ij
14505           evdwij=ev1+ev2
14506           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14507           el2=fac4*fac
14508           eesij=el1+el2
14509 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14510           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14511           ees=ees+eesij*sss_ele_cut
14512           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14513 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14514 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14515 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14516 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14517
14518           if (energy_dec) then
14519               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14520               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14521           endif
14522
14523 !
14524 ! Calculate contributions to the Cartesian gradient.
14525 !
14526 #ifdef SPLITELE
14527           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14528           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14529           fac1=fac
14530           erij(1)=xj*rmij
14531           erij(2)=yj*rmij
14532           erij(3)=zj*rmij
14533 !
14534 ! Radial derivatives. First process both termini of the fragment (i,j)
14535 !
14536           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14537           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14538           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14539 !          do k=1,3
14540 !            ghalf=0.5D0*ggg(k)
14541 !            gelc(k,i)=gelc(k,i)+ghalf
14542 !            gelc(k,j)=gelc(k,j)+ghalf
14543 !          enddo
14544 ! 9/28/08 AL Gradient compotents will be summed only at the end
14545           do k=1,3
14546             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14547             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14548           enddo
14549 !
14550 ! Loop over residues i+1 thru j-1.
14551 !
14552 !grad          do k=i+1,j-1
14553 !grad            do l=1,3
14554 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14555 !grad            enddo
14556 !grad          enddo
14557           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14558           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14559           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14560           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14561           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14562           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14563 !          do k=1,3
14564 !            ghalf=0.5D0*ggg(k)
14565 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14566 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14567 !          enddo
14568 ! 9/28/08 AL Gradient compotents will be summed only at the end
14569           do k=1,3
14570             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14571             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14572           enddo
14573 !
14574 ! Loop over residues i+1 thru j-1.
14575 !
14576 !grad          do k=i+1,j-1
14577 !grad            do l=1,3
14578 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14579 !grad            enddo
14580 !grad          enddo
14581 #else
14582           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14583           facel=(el1+eesij)*sss_ele_cut
14584           fac1=fac
14585           fac=-3*rrmij*(facvdw+facvdw+facel)
14586           erij(1)=xj*rmij
14587           erij(2)=yj*rmij
14588           erij(3)=zj*rmij
14589 !
14590 ! Radial derivatives. First process both termini of the fragment (i,j)
14591 !
14592           ggg(1)=fac*xj
14593           ggg(2)=fac*yj
14594           ggg(3)=fac*zj
14595 !          do k=1,3
14596 !            ghalf=0.5D0*ggg(k)
14597 !            gelc(k,i)=gelc(k,i)+ghalf
14598 !            gelc(k,j)=gelc(k,j)+ghalf
14599 !          enddo
14600 ! 9/28/08 AL Gradient compotents will be summed only at the end
14601           do k=1,3
14602             gelc_long(k,j)=gelc(k,j)+ggg(k)
14603             gelc_long(k,i)=gelc(k,i)-ggg(k)
14604           enddo
14605 !
14606 ! Loop over residues i+1 thru j-1.
14607 !
14608 !grad          do k=i+1,j-1
14609 !grad            do l=1,3
14610 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14611 !grad            enddo
14612 !grad          enddo
14613 ! 9/28/08 AL Gradient compotents will be summed only at the end
14614           ggg(1)=facvdw*xj
14615           ggg(2)=facvdw*yj
14616           ggg(3)=facvdw*zj
14617           do k=1,3
14618             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14619             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14620           enddo
14621 #endif
14622 !
14623 ! Angular part
14624 !
14625           ecosa=2.0D0*fac3*fac1+fac4
14626           fac4=-3.0D0*fac4
14627           fac3=-6.0D0*fac3
14628           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14629           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14630           do k=1,3
14631             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14632             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14633           enddo
14634 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14635 !d   &          (dcosg(k),k=1,3)
14636           do k=1,3
14637             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14638           enddo
14639 !          do k=1,3
14640 !            ghalf=0.5D0*ggg(k)
14641 !            gelc(k,i)=gelc(k,i)+ghalf
14642 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14643 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14644 !            gelc(k,j)=gelc(k,j)+ghalf
14645 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14646 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14647 !          enddo
14648 !grad          do k=i+1,j-1
14649 !grad            do l=1,3
14650 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14651 !grad            enddo
14652 !grad          enddo
14653           do k=1,3
14654             gelc(k,i)=gelc(k,i) &
14655                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14656                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
14657                      *sss_ele_cut
14658             gelc(k,j)=gelc(k,j) &
14659                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14660                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14661                      *sss_ele_cut
14662             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14663             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14664           enddo
14665           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14666               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
14667               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14668 !
14669 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
14670 !   energy of a peptide unit is assumed in the form of a second-order
14671 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
14672 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
14673 !   are computed for EVERY pair of non-contiguous peptide groups.
14674 !
14675           if (j.lt.nres-1) then
14676             j1=j+1
14677             j2=j-1
14678           else
14679             j1=j-1
14680             j2=j-2
14681           endif
14682           kkk=0
14683           do k=1,2
14684             do l=1,2
14685               kkk=kkk+1
14686               muij(kkk)=mu(k,i)*mu(l,j)
14687             enddo
14688           enddo
14689 !d         write (iout,*) 'EELEC: i',i,' j',j
14690 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
14691 !d          write(iout,*) 'muij',muij
14692           ury=scalar(uy(1,i),erij)
14693           urz=scalar(uz(1,i),erij)
14694           vry=scalar(uy(1,j),erij)
14695           vrz=scalar(uz(1,j),erij)
14696           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
14697           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
14698           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
14699           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
14700           fac=dsqrt(-ael6i)*r3ij
14701           a22=a22*fac
14702           a23=a23*fac
14703           a32=a32*fac
14704           a33=a33*fac
14705 !d          write (iout,'(4i5,4f10.5)')
14706 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
14707 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
14708 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
14709 !d     &      uy(:,j),uz(:,j)
14710 !d          write (iout,'(4f10.5)')
14711 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
14712 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
14713 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
14714 !d           write (iout,'(9f10.5/)')
14715 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
14716 ! Derivatives of the elements of A in virtual-bond vectors
14717           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
14718           do k=1,3
14719             uryg(k,1)=scalar(erder(1,k),uy(1,i))
14720             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
14721             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
14722             urzg(k,1)=scalar(erder(1,k),uz(1,i))
14723             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
14724             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
14725             vryg(k,1)=scalar(erder(1,k),uy(1,j))
14726             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
14727             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
14728             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
14729             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
14730             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
14731           enddo
14732 ! Compute radial contributions to the gradient
14733           facr=-3.0d0*rrmij
14734           a22der=a22*facr
14735           a23der=a23*facr
14736           a32der=a32*facr
14737           a33der=a33*facr
14738           agg(1,1)=a22der*xj
14739           agg(2,1)=a22der*yj
14740           agg(3,1)=a22der*zj
14741           agg(1,2)=a23der*xj
14742           agg(2,2)=a23der*yj
14743           agg(3,2)=a23der*zj
14744           agg(1,3)=a32der*xj
14745           agg(2,3)=a32der*yj
14746           agg(3,3)=a32der*zj
14747           agg(1,4)=a33der*xj
14748           agg(2,4)=a33der*yj
14749           agg(3,4)=a33der*zj
14750 ! Add the contributions coming from er
14751           fac3=-3.0d0*fac
14752           do k=1,3
14753             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
14754             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
14755             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
14756             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
14757           enddo
14758           do k=1,3
14759 ! Derivatives in DC(i)
14760 !grad            ghalf1=0.5d0*agg(k,1)
14761 !grad            ghalf2=0.5d0*agg(k,2)
14762 !grad            ghalf3=0.5d0*agg(k,3)
14763 !grad            ghalf4=0.5d0*agg(k,4)
14764             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14765             -3.0d0*uryg(k,2)*vry)!+ghalf1
14766             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14767             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14768             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14769             -3.0d0*urzg(k,2)*vry)!+ghalf3
14770             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14771             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14772 ! Derivatives in DC(i+1)
14773             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14774             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14775             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14776             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14777             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14778             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14779             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14780             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14781 ! Derivatives in DC(j)
14782             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14783             -3.0d0*vryg(k,2)*ury)!+ghalf1
14784             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14785             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14786             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14787             -3.0d0*vryg(k,2)*urz)!+ghalf3
14788             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14789             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14790 ! Derivatives in DC(j+1) or DC(nres-1)
14791             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14792             -3.0d0*vryg(k,3)*ury)
14793             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14794             -3.0d0*vrzg(k,3)*ury)
14795             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14796             -3.0d0*vryg(k,3)*urz)
14797             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14798             -3.0d0*vrzg(k,3)*urz)
14799 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14800 !grad              do l=1,4
14801 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14802 !grad              enddo
14803 !grad            endif
14804           enddo
14805           acipa(1,1)=a22
14806           acipa(1,2)=a23
14807           acipa(2,1)=a32
14808           acipa(2,2)=a33
14809           a22=-a22
14810           a23=-a23
14811           do l=1,2
14812             do k=1,3
14813               agg(k,l)=-agg(k,l)
14814               aggi(k,l)=-aggi(k,l)
14815               aggi1(k,l)=-aggi1(k,l)
14816               aggj(k,l)=-aggj(k,l)
14817               aggj1(k,l)=-aggj1(k,l)
14818             enddo
14819           enddo
14820           if (j.lt.nres-1) then
14821             a22=-a22
14822             a32=-a32
14823             do l=1,3,2
14824               do k=1,3
14825                 agg(k,l)=-agg(k,l)
14826                 aggi(k,l)=-aggi(k,l)
14827                 aggi1(k,l)=-aggi1(k,l)
14828                 aggj(k,l)=-aggj(k,l)
14829                 aggj1(k,l)=-aggj1(k,l)
14830               enddo
14831             enddo
14832           else
14833             a22=-a22
14834             a23=-a23
14835             a32=-a32
14836             a33=-a33
14837             do l=1,4
14838               do k=1,3
14839                 agg(k,l)=-agg(k,l)
14840                 aggi(k,l)=-aggi(k,l)
14841                 aggi1(k,l)=-aggi1(k,l)
14842                 aggj(k,l)=-aggj(k,l)
14843                 aggj1(k,l)=-aggj1(k,l)
14844               enddo
14845             enddo
14846           endif
14847           ENDIF ! WCORR
14848           IF (wel_loc.gt.0.0d0) THEN
14849 ! Contribution to the local-electrostatic energy coming from the i-j pair
14850           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14851            +a33*muij(4)
14852 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14853 !           print *,"EELLOC",i,gel_loc_loc(i-1)
14854           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14855                   'eelloc',i,j,eel_loc_ij
14856 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14857
14858           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14859 ! Partial derivatives in virtual-bond dihedral angles gamma
14860           if (i.gt.1) &
14861           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14862                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14863                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14864                  *sss_ele_cut
14865           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14866                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14867                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14868                  *sss_ele_cut
14869            xtemp(1)=xj
14870            xtemp(2)=yj
14871            xtemp(3)=zj
14872
14873 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14874           do l=1,3
14875             ggg(l)=(agg(l,1)*muij(1)+ &
14876                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14877             *sss_ele_cut &
14878              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14879
14880             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14881             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14882 !grad            ghalf=0.5d0*ggg(l)
14883 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14884 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14885           enddo
14886 !grad          do k=i+1,j2
14887 !grad            do l=1,3
14888 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14889 !grad            enddo
14890 !grad          enddo
14891 ! Remaining derivatives of eello
14892           do l=1,3
14893             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14894                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14895             *sss_ele_cut
14896
14897             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14898                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14899             *sss_ele_cut
14900
14901             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14902                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14903             *sss_ele_cut
14904
14905             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14906                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14907             *sss_ele_cut
14908
14909           enddo
14910           ENDIF
14911 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14912 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14913           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14914              .and. num_conti.le.maxconts) then
14915 !            write (iout,*) i,j," entered corr"
14916 !
14917 ! Calculate the contact function. The ith column of the array JCONT will
14918 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14919 ! greater than I). The arrays FACONT and GACONT will contain the values of
14920 ! the contact function and its derivative.
14921 !           r0ij=1.02D0*rpp(iteli,itelj)
14922 !           r0ij=1.11D0*rpp(iteli,itelj)
14923             r0ij=2.20D0*rpp(iteli,itelj)
14924 !           r0ij=1.55D0*rpp(iteli,itelj)
14925             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14926 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14927             if (fcont.gt.0.0D0) then
14928               num_conti=num_conti+1
14929               if (num_conti.gt.maxconts) then
14930 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14931                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14932                                ' will skip next contacts for this conf.',num_conti
14933               else
14934                 jcont_hb(num_conti,i)=j
14935 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14936 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14937                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14938                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14939 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14940 !  terms.
14941                 d_cont(num_conti,i)=rij
14942 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14943 !     --- Electrostatic-interaction matrix ---
14944                 a_chuj(1,1,num_conti,i)=a22
14945                 a_chuj(1,2,num_conti,i)=a23
14946                 a_chuj(2,1,num_conti,i)=a32
14947                 a_chuj(2,2,num_conti,i)=a33
14948 !     --- Gradient of rij
14949                 do kkk=1,3
14950                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14951                 enddo
14952                 kkll=0
14953                 do k=1,2
14954                   do l=1,2
14955                     kkll=kkll+1
14956                     do m=1,3
14957                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14958                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14959                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14960                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14961                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14962                     enddo
14963                   enddo
14964                 enddo
14965                 ENDIF
14966                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14967 ! Calculate contact energies
14968                 cosa4=4.0D0*cosa
14969                 wij=cosa-3.0D0*cosb*cosg
14970                 cosbg1=cosb+cosg
14971                 cosbg2=cosb-cosg
14972 !               fac3=dsqrt(-ael6i)/r0ij**3
14973                 fac3=dsqrt(-ael6i)*r3ij
14974 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14975                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14976                 if (ees0tmp.gt.0) then
14977                   ees0pij=dsqrt(ees0tmp)
14978                 else
14979                   ees0pij=0
14980                 endif
14981 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14982                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14983                 if (ees0tmp.gt.0) then
14984                   ees0mij=dsqrt(ees0tmp)
14985                 else
14986                   ees0mij=0
14987                 endif
14988 !               ees0mij=0.0D0
14989                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14990                      *sss_ele_cut
14991
14992                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14993                      *sss_ele_cut
14994
14995 ! Diagnostics. Comment out or remove after debugging!
14996 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14997 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14998 !               ees0m(num_conti,i)=0.0D0
14999 ! End diagnostics.
15000 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
15001 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
15002 ! Angular derivatives of the contact function
15003                 ees0pij1=fac3/ees0pij
15004                 ees0mij1=fac3/ees0mij
15005                 fac3p=-3.0D0*fac3*rrmij
15006                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
15007                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
15008 !               ees0mij1=0.0D0
15009                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
15010                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
15011                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
15012                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
15013                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
15014                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
15015                 ecosap=ecosa1+ecosa2
15016                 ecosbp=ecosb1+ecosb2
15017                 ecosgp=ecosg1+ecosg2
15018                 ecosam=ecosa1-ecosa2
15019                 ecosbm=ecosb1-ecosb2
15020                 ecosgm=ecosg1-ecosg2
15021 ! Diagnostics
15022 !               ecosap=ecosa1
15023 !               ecosbp=ecosb1
15024 !               ecosgp=ecosg1
15025 !               ecosam=0.0D0
15026 !               ecosbm=0.0D0
15027 !               ecosgm=0.0D0
15028 ! End diagnostics
15029                 facont_hb(num_conti,i)=fcont
15030                 fprimcont=fprimcont/rij
15031 !d              facont_hb(num_conti,i)=1.0D0
15032 ! Following line is for diagnostics.
15033 !d              fprimcont=0.0D0
15034                 do k=1,3
15035                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
15036                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
15037                 enddo
15038                 do k=1,3
15039                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
15040                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
15041                 enddo
15042 !                gggp(1)=gggp(1)+ees0pijp*xj
15043 !                gggp(2)=gggp(2)+ees0pijp*yj
15044 !                gggp(3)=gggp(3)+ees0pijp*zj
15045 !                gggm(1)=gggm(1)+ees0mijp*xj
15046 !                gggm(2)=gggm(2)+ees0mijp*yj
15047 !                gggm(3)=gggm(3)+ees0mijp*zj
15048                 gggp(1)=gggp(1)+ees0pijp*xj &
15049                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15050                 gggp(2)=gggp(2)+ees0pijp*yj &
15051                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15052                 gggp(3)=gggp(3)+ees0pijp*zj &
15053                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15054
15055                 gggm(1)=gggm(1)+ees0mijp*xj &
15056                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
15057
15058                 gggm(2)=gggm(2)+ees0mijp*yj &
15059                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
15060
15061                 gggm(3)=gggm(3)+ees0mijp*zj &
15062                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
15063
15064 ! Derivatives due to the contact function
15065                 gacont_hbr(1,num_conti,i)=fprimcont*xj
15066                 gacont_hbr(2,num_conti,i)=fprimcont*yj
15067                 gacont_hbr(3,num_conti,i)=fprimcont*zj
15068                 do k=1,3
15069 !
15070 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
15071 !          following the change of gradient-summation algorithm.
15072 !
15073 !grad                  ghalfp=0.5D0*gggp(k)
15074 !grad                  ghalfm=0.5D0*gggm(k)
15075 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
15076 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15077 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15078 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
15079 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15080 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15081 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
15082 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
15083 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15084 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
15085 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
15086 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15087 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
15088 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
15089                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
15090                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15091                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15092                      *sss_ele_cut
15093
15094                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
15095                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15096                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
15097                      *sss_ele_cut
15098
15099                   gacontp_hb3(k,num_conti,i)=gggp(k) &
15100                      *sss_ele_cut
15101
15102                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
15103                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
15104                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
15105                      *sss_ele_cut
15106
15107                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
15108                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
15109                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
15110                      *sss_ele_cut
15111
15112                   gacontm_hb3(k,num_conti,i)=gggm(k) &
15113                      *sss_ele_cut
15114
15115                 enddo
15116               ENDIF ! wcorr
15117               endif  ! num_conti.le.maxconts
15118             endif  ! fcont.gt.0
15119           endif    ! j.gt.i+1
15120           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
15121             do k=1,4
15122               do l=1,3
15123                 ghalf=0.5d0*agg(l,k)
15124                 aggi(l,k)=aggi(l,k)+ghalf
15125                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
15126                 aggj(l,k)=aggj(l,k)+ghalf
15127               enddo
15128             enddo
15129             if (j.eq.nres-1 .and. i.lt.j-2) then
15130               do k=1,4
15131                 do l=1,3
15132                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
15133                 enddo
15134               enddo
15135             endif
15136           endif
15137  128      continue
15138 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
15139       return
15140       end subroutine eelecij_scale
15141 !-----------------------------------------------------------------------------
15142       subroutine evdwpp_short(evdw1)
15143 !
15144 ! Compute Evdwpp
15145 !
15146 !      implicit real*8 (a-h,o-z)
15147 !      include 'DIMENSIONS'
15148 !      include 'COMMON.CONTROL'
15149 !      include 'COMMON.IOUNITS'
15150 !      include 'COMMON.GEO'
15151 !      include 'COMMON.VAR'
15152 !      include 'COMMON.LOCAL'
15153 !      include 'COMMON.CHAIN'
15154 !      include 'COMMON.DERIV'
15155 !      include 'COMMON.INTERACT'
15156 !      include 'COMMON.CONTACTS'
15157 !      include 'COMMON.TORSION'
15158 !      include 'COMMON.VECTORS'
15159 !      include 'COMMON.FFIELD'
15160       real(kind=8),dimension(3) :: ggg
15161 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
15162 #ifdef MOMENT
15163       real(kind=8) :: scal_el=1.0d0
15164 #else
15165       real(kind=8) :: scal_el=0.5d0
15166 #endif
15167 !el local variables
15168       integer :: i,j,k,iteli,itelj,num_conti,isubchap
15169       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
15170       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
15171                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
15172                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
15173       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15174                     dist_temp, dist_init,sss_grad
15175       integer xshift,yshift,zshift
15176
15177
15178       evdw1=0.0D0
15179 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
15180 !     & " iatel_e_vdw",iatel_e_vdw
15181       call flush(iout)
15182       do i=iatel_s_vdw,iatel_e_vdw
15183         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
15184         dxi=dc(1,i)
15185         dyi=dc(2,i)
15186         dzi=dc(3,i)
15187         dx_normi=dc_norm(1,i)
15188         dy_normi=dc_norm(2,i)
15189         dz_normi=dc_norm(3,i)
15190         xmedi=c(1,i)+0.5d0*dxi
15191         ymedi=c(2,i)+0.5d0*dyi
15192         zmedi=c(3,i)+0.5d0*dzi
15193           xmedi=dmod(xmedi,boxxsize)
15194           if (xmedi.lt.0) xmedi=xmedi+boxxsize
15195           ymedi=dmod(ymedi,boxysize)
15196           if (ymedi.lt.0) ymedi=ymedi+boxysize
15197           zmedi=dmod(zmedi,boxzsize)
15198           if (zmedi.lt.0) zmedi=zmedi+boxzsize
15199         num_conti=0
15200 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
15201 !     &   ' ielend',ielend_vdw(i)
15202         call flush(iout)
15203         do j=ielstart_vdw(i),ielend_vdw(i)
15204           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15205 !el          ind=ind+1
15206           iteli=itel(i)
15207           itelj=itel(j)
15208           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15209           aaa=app(iteli,itelj)
15210           bbb=bpp(iteli,itelj)
15211           dxj=dc(1,j)
15212           dyj=dc(2,j)
15213           dzj=dc(3,j)
15214           dx_normj=dc_norm(1,j)
15215           dy_normj=dc_norm(2,j)
15216           dz_normj=dc_norm(3,j)
15217 !          xj=c(1,j)+0.5D0*dxj-xmedi
15218 !          yj=c(2,j)+0.5D0*dyj-ymedi
15219 !          zj=c(3,j)+0.5D0*dzj-zmedi
15220           xj=c(1,j)+0.5D0*dxj
15221           yj=c(2,j)+0.5D0*dyj
15222           zj=c(3,j)+0.5D0*dzj
15223           xj=mod(xj,boxxsize)
15224           if (xj.lt.0) xj=xj+boxxsize
15225           yj=mod(yj,boxysize)
15226           if (yj.lt.0) yj=yj+boxysize
15227           zj=mod(zj,boxzsize)
15228           if (zj.lt.0) zj=zj+boxzsize
15229       isubchap=0
15230       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15231       xj_safe=xj
15232       yj_safe=yj
15233       zj_safe=zj
15234       do xshift=-1,1
15235       do yshift=-1,1
15236       do zshift=-1,1
15237           xj=xj_safe+xshift*boxxsize
15238           yj=yj_safe+yshift*boxysize
15239           zj=zj_safe+zshift*boxzsize
15240           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15241           if(dist_temp.lt.dist_init) then
15242             dist_init=dist_temp
15243             xj_temp=xj
15244             yj_temp=yj
15245             zj_temp=zj
15246             isubchap=1
15247           endif
15248        enddo
15249        enddo
15250        enddo
15251        if (isubchap.eq.1) then
15252 !C          print *,i,j
15253           xj=xj_temp-xmedi
15254           yj=yj_temp-ymedi
15255           zj=zj_temp-zmedi
15256        else
15257           xj=xj_safe-xmedi
15258           yj=yj_safe-ymedi
15259           zj=zj_safe-zmedi
15260        endif
15261
15262           rij=xj*xj+yj*yj+zj*zj
15263           rrmij=1.0D0/rij
15264           rij=dsqrt(rij)
15265           sss=sscale(rij/rpp(iteli,itelj))
15266             sss_ele_cut=sscale_ele(rij)
15267             sss_ele_grad=sscagrad_ele(rij)
15268             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15269             if (sss_ele_cut.le.0.0) cycle
15270           if (sss.gt.0.0d0) then
15271             rmij=1.0D0/rij
15272             r3ij=rrmij*rmij
15273             r6ij=r3ij*r3ij
15274             ev1=aaa*r6ij*r6ij
15275 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15276             if (j.eq.i+2) ev1=scal_el*ev1
15277             ev2=bbb*r6ij
15278             evdwij=ev1+ev2
15279             if (energy_dec) then
15280               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15281             endif
15282             evdw1=evdw1+evdwij*sss*sss_ele_cut
15283 !
15284 ! Calculate contributions to the Cartesian gradient.
15285 !
15286             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15287 !            ggg(1)=facvdw*xj
15288 !            ggg(2)=facvdw*yj
15289 !            ggg(3)=facvdw*zj
15290           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15291           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15292           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15293           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15294           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15295           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15296
15297             do k=1,3
15298               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15299               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15300             enddo
15301           endif
15302         enddo ! j
15303       enddo   ! i
15304       return
15305       end subroutine evdwpp_short
15306 !-----------------------------------------------------------------------------
15307       subroutine escp_long(evdw2,evdw2_14)
15308 !
15309 ! This subroutine calculates the excluded-volume interaction energy between
15310 ! peptide-group centers and side chains and its gradient in virtual-bond and
15311 ! side-chain vectors.
15312 !
15313 !      implicit real*8 (a-h,o-z)
15314 !      include 'DIMENSIONS'
15315 !      include 'COMMON.GEO'
15316 !      include 'COMMON.VAR'
15317 !      include 'COMMON.LOCAL'
15318 !      include 'COMMON.CHAIN'
15319 !      include 'COMMON.DERIV'
15320 !      include 'COMMON.INTERACT'
15321 !      include 'COMMON.FFIELD'
15322 !      include 'COMMON.IOUNITS'
15323 !      include 'COMMON.CONTROL'
15324       real(kind=8),dimension(3) :: ggg
15325 !el local variables
15326       integer :: i,iint,j,k,iteli,itypj,subchap
15327       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15328       real(kind=8) :: evdw2,evdw2_14,evdwij
15329       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15330                     dist_temp, dist_init
15331
15332       evdw2=0.0D0
15333       evdw2_14=0.0d0
15334 !d    print '(a)','Enter ESCP'
15335 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15336       do i=iatscp_s,iatscp_e
15337         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15338         iteli=itel(i)
15339         xi=0.5D0*(c(1,i)+c(1,i+1))
15340         yi=0.5D0*(c(2,i)+c(2,i+1))
15341         zi=0.5D0*(c(3,i)+c(3,i+1))
15342           xi=mod(xi,boxxsize)
15343           if (xi.lt.0) xi=xi+boxxsize
15344           yi=mod(yi,boxysize)
15345           if (yi.lt.0) yi=yi+boxysize
15346           zi=mod(zi,boxzsize)
15347           if (zi.lt.0) zi=zi+boxzsize
15348
15349         do iint=1,nscp_gr(i)
15350
15351         do j=iscpstart(i,iint),iscpend(i,iint)
15352           itypj=itype(j,1)
15353           if (itypj.eq.ntyp1) cycle
15354 ! Uncomment following three lines for SC-p interactions
15355 !         xj=c(1,nres+j)-xi
15356 !         yj=c(2,nres+j)-yi
15357 !         zj=c(3,nres+j)-zi
15358 ! Uncomment following three lines for Ca-p interactions
15359           xj=c(1,j)
15360           yj=c(2,j)
15361           zj=c(3,j)
15362           xj=mod(xj,boxxsize)
15363           if (xj.lt.0) xj=xj+boxxsize
15364           yj=mod(yj,boxysize)
15365           if (yj.lt.0) yj=yj+boxysize
15366           zj=mod(zj,boxzsize)
15367           if (zj.lt.0) zj=zj+boxzsize
15368       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15369       xj_safe=xj
15370       yj_safe=yj
15371       zj_safe=zj
15372       subchap=0
15373       do xshift=-1,1
15374       do yshift=-1,1
15375       do zshift=-1,1
15376           xj=xj_safe+xshift*boxxsize
15377           yj=yj_safe+yshift*boxysize
15378           zj=zj_safe+zshift*boxzsize
15379           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15380           if(dist_temp.lt.dist_init) then
15381             dist_init=dist_temp
15382             xj_temp=xj
15383             yj_temp=yj
15384             zj_temp=zj
15385             subchap=1
15386           endif
15387        enddo
15388        enddo
15389        enddo
15390        if (subchap.eq.1) then
15391           xj=xj_temp-xi
15392           yj=yj_temp-yi
15393           zj=zj_temp-zi
15394        else
15395           xj=xj_safe-xi
15396           yj=yj_safe-yi
15397           zj=zj_safe-zi
15398        endif
15399           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15400
15401           rij=dsqrt(1.0d0/rrij)
15402             sss_ele_cut=sscale_ele(rij)
15403             sss_ele_grad=sscagrad_ele(rij)
15404 !            print *,sss_ele_cut,sss_ele_grad,&
15405 !            (rij),r_cut_ele,rlamb_ele
15406             if (sss_ele_cut.le.0.0) cycle
15407           sss=sscale((rij/rscp(itypj,iteli)))
15408           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15409           if (sss.lt.1.0d0) then
15410
15411             fac=rrij**expon2
15412             e1=fac*fac*aad(itypj,iteli)
15413             e2=fac*bad(itypj,iteli)
15414             if (iabs(j-i) .le. 2) then
15415               e1=scal14*e1
15416               e2=scal14*e2
15417               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15418             endif
15419             evdwij=e1+e2
15420             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15421             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15422                 'evdw2',i,j,sss,evdwij
15423 !
15424 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15425 !
15426             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15427             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15428             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15429             ggg(1)=xj*fac
15430             ggg(2)=yj*fac
15431             ggg(3)=zj*fac
15432 ! Uncomment following three lines for SC-p interactions
15433 !           do k=1,3
15434 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15435 !           enddo
15436 ! Uncomment following line for SC-p interactions
15437 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15438             do k=1,3
15439               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15440               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15441             enddo
15442           endif
15443         enddo
15444
15445         enddo ! iint
15446       enddo ! i
15447       do i=1,nct
15448         do j=1,3
15449           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15450           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15451           gradx_scp(j,i)=expon*gradx_scp(j,i)
15452         enddo
15453       enddo
15454 !******************************************************************************
15455 !
15456 !                              N O T E !!!
15457 !
15458 ! To save time the factor EXPON has been extracted from ALL components
15459 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15460 ! use!
15461 !
15462 !******************************************************************************
15463       return
15464       end subroutine escp_long
15465 !-----------------------------------------------------------------------------
15466       subroutine escp_short(evdw2,evdw2_14)
15467 !
15468 ! This subroutine calculates the excluded-volume interaction energy between
15469 ! peptide-group centers and side chains and its gradient in virtual-bond and
15470 ! side-chain vectors.
15471 !
15472 !      implicit real*8 (a-h,o-z)
15473 !      include 'DIMENSIONS'
15474 !      include 'COMMON.GEO'
15475 !      include 'COMMON.VAR'
15476 !      include 'COMMON.LOCAL'
15477 !      include 'COMMON.CHAIN'
15478 !      include 'COMMON.DERIV'
15479 !      include 'COMMON.INTERACT'
15480 !      include 'COMMON.FFIELD'
15481 !      include 'COMMON.IOUNITS'
15482 !      include 'COMMON.CONTROL'
15483       real(kind=8),dimension(3) :: ggg
15484 !el local variables
15485       integer :: i,iint,j,k,iteli,itypj,subchap
15486       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15487       real(kind=8) :: evdw2,evdw2_14,evdwij
15488       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15489                     dist_temp, dist_init
15490
15491       evdw2=0.0D0
15492       evdw2_14=0.0d0
15493 !d    print '(a)','Enter ESCP'
15494 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15495       do i=iatscp_s,iatscp_e
15496         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15497         iteli=itel(i)
15498         xi=0.5D0*(c(1,i)+c(1,i+1))
15499         yi=0.5D0*(c(2,i)+c(2,i+1))
15500         zi=0.5D0*(c(3,i)+c(3,i+1))
15501           xi=mod(xi,boxxsize)
15502           if (xi.lt.0) xi=xi+boxxsize
15503           yi=mod(yi,boxysize)
15504           if (yi.lt.0) yi=yi+boxysize
15505           zi=mod(zi,boxzsize)
15506           if (zi.lt.0) zi=zi+boxzsize
15507
15508         do iint=1,nscp_gr(i)
15509
15510         do j=iscpstart(i,iint),iscpend(i,iint)
15511           itypj=itype(j,1)
15512           if (itypj.eq.ntyp1) cycle
15513 ! Uncomment following three lines for SC-p interactions
15514 !         xj=c(1,nres+j)-xi
15515 !         yj=c(2,nres+j)-yi
15516 !         zj=c(3,nres+j)-zi
15517 ! Uncomment following three lines for Ca-p interactions
15518 !          xj=c(1,j)-xi
15519 !          yj=c(2,j)-yi
15520 !          zj=c(3,j)-zi
15521           xj=c(1,j)
15522           yj=c(2,j)
15523           zj=c(3,j)
15524           xj=mod(xj,boxxsize)
15525           if (xj.lt.0) xj=xj+boxxsize
15526           yj=mod(yj,boxysize)
15527           if (yj.lt.0) yj=yj+boxysize
15528           zj=mod(zj,boxzsize)
15529           if (zj.lt.0) zj=zj+boxzsize
15530       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15531       xj_safe=xj
15532       yj_safe=yj
15533       zj_safe=zj
15534       subchap=0
15535       do xshift=-1,1
15536       do yshift=-1,1
15537       do zshift=-1,1
15538           xj=xj_safe+xshift*boxxsize
15539           yj=yj_safe+yshift*boxysize
15540           zj=zj_safe+zshift*boxzsize
15541           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15542           if(dist_temp.lt.dist_init) then
15543             dist_init=dist_temp
15544             xj_temp=xj
15545             yj_temp=yj
15546             zj_temp=zj
15547             subchap=1
15548           endif
15549        enddo
15550        enddo
15551        enddo
15552        if (subchap.eq.1) then
15553           xj=xj_temp-xi
15554           yj=yj_temp-yi
15555           zj=zj_temp-zi
15556        else
15557           xj=xj_safe-xi
15558           yj=yj_safe-yi
15559           zj=zj_safe-zi
15560        endif
15561
15562           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15563           rij=dsqrt(1.0d0/rrij)
15564             sss_ele_cut=sscale_ele(rij)
15565             sss_ele_grad=sscagrad_ele(rij)
15566 !            print *,sss_ele_cut,sss_ele_grad,&
15567 !            (rij),r_cut_ele,rlamb_ele
15568             if (sss_ele_cut.le.0.0) cycle
15569           sss=sscale(rij/rscp(itypj,iteli))
15570           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15571           if (sss.gt.0.0d0) then
15572
15573             fac=rrij**expon2
15574             e1=fac*fac*aad(itypj,iteli)
15575             e2=fac*bad(itypj,iteli)
15576             if (iabs(j-i) .le. 2) then
15577               e1=scal14*e1
15578               e2=scal14*e2
15579               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15580             endif
15581             evdwij=e1+e2
15582             evdw2=evdw2+evdwij*sss*sss_ele_cut
15583             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15584                 'evdw2',i,j,sss,evdwij
15585 !
15586 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15587 !
15588             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15589             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15590             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15591
15592             ggg(1)=xj*fac
15593             ggg(2)=yj*fac
15594             ggg(3)=zj*fac
15595 ! Uncomment following three lines for SC-p interactions
15596 !           do k=1,3
15597 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15598 !           enddo
15599 ! Uncomment following line for SC-p interactions
15600 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15601             do k=1,3
15602               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15603               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15604             enddo
15605           endif
15606         enddo
15607
15608         enddo ! iint
15609       enddo ! i
15610       do i=1,nct
15611         do j=1,3
15612           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15613           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15614           gradx_scp(j,i)=expon*gradx_scp(j,i)
15615         enddo
15616       enddo
15617 !******************************************************************************
15618 !
15619 !                              N O T E !!!
15620 !
15621 ! To save time the factor EXPON has been extracted from ALL components
15622 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15623 ! use!
15624 !
15625 !******************************************************************************
15626       return
15627       end subroutine escp_short
15628 !-----------------------------------------------------------------------------
15629 ! energy_p_new-sep_barrier.F
15630 !-----------------------------------------------------------------------------
15631       subroutine sc_grad_scale(scalfac)
15632 !      implicit real*8 (a-h,o-z)
15633       use calc_data
15634 !      include 'DIMENSIONS'
15635 !      include 'COMMON.CHAIN'
15636 !      include 'COMMON.DERIV'
15637 !      include 'COMMON.CALC'
15638 !      include 'COMMON.IOUNITS'
15639       real(kind=8),dimension(3) :: dcosom1,dcosom2
15640       real(kind=8) :: scalfac
15641 !el local variables
15642 !      integer :: i,j,k,l
15643
15644       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15645       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15646       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15647            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15648 ! diagnostics only
15649 !      eom1=0.0d0
15650 !      eom2=0.0d0
15651 !      eom12=evdwij*eps1_om12
15652 ! end diagnostics
15653 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15654 !     &  " sigder",sigder
15655 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15656 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15657       do k=1,3
15658         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15659         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15660       enddo
15661       do k=1,3
15662         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15663          *sss_ele_cut
15664       enddo
15665 !      write (iout,*) "gg",(gg(k),k=1,3)
15666       do k=1,3
15667         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15668                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15669                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15670                  *sss_ele_cut
15671         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15672                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15673                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15674          *sss_ele_cut
15675 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15676 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15677 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15678 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15679       enddo
15680 !
15681 ! Calculate the components of the gradient in DC and X
15682 !
15683       do l=1,3
15684         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15685         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15686       enddo
15687       return
15688       end subroutine sc_grad_scale
15689 !-----------------------------------------------------------------------------
15690 ! energy_split-sep.F
15691 !-----------------------------------------------------------------------------
15692       subroutine etotal_long(energia)
15693 !
15694 ! Compute the long-range slow-varying contributions to the energy
15695 !
15696 !      implicit real*8 (a-h,o-z)
15697 !      include 'DIMENSIONS'
15698       use MD_data, only: totT,usampl,eq_time
15699 #ifndef ISNAN
15700       external proc_proc
15701 #ifdef WINPGI
15702 !MS$ATTRIBUTES C ::  proc_proc
15703 #endif
15704 #endif
15705 #ifdef MPI
15706       include "mpif.h"
15707       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15708 #endif
15709 !      include 'COMMON.SETUP'
15710 !      include 'COMMON.IOUNITS'
15711 !      include 'COMMON.FFIELD'
15712 !      include 'COMMON.DERIV'
15713 !      include 'COMMON.INTERACT'
15714 !      include 'COMMON.SBRIDGE'
15715 !      include 'COMMON.CHAIN'
15716 !      include 'COMMON.VAR'
15717 !      include 'COMMON.LOCAL'
15718 !      include 'COMMON.MD'
15719       real(kind=8),dimension(0:n_ene) :: energia
15720 !el local variables
15721       integer :: i,n_corr,n_corr1,ierror,ierr
15722       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15723                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15724                   ecorr,ecorr5,ecorr6,eturn6,time00
15725 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15726 !elwrite(iout,*)"in etotal long"
15727
15728       if (modecalc.eq.12.or.modecalc.eq.14) then
15729 #ifdef MPI
15730 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15731 #else
15732         call int_from_cart1(.false.)
15733 #endif
15734       endif
15735 !elwrite(iout,*)"in etotal long"
15736
15737 #ifdef MPI
15738 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15739 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15740       call flush(iout)
15741       if (nfgtasks.gt.1) then
15742         time00=MPI_Wtime()
15743 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15744         if (fg_rank.eq.0) then
15745           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15746 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15747 !          call flush(iout)
15748 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15749 ! FG slaves as WEIGHTS array.
15750           weights_(1)=wsc
15751           weights_(2)=wscp
15752           weights_(3)=welec
15753           weights_(4)=wcorr
15754           weights_(5)=wcorr5
15755           weights_(6)=wcorr6
15756           weights_(7)=wel_loc
15757           weights_(8)=wturn3
15758           weights_(9)=wturn4
15759           weights_(10)=wturn6
15760           weights_(11)=wang
15761           weights_(12)=wscloc
15762           weights_(13)=wtor
15763           weights_(14)=wtor_d
15764           weights_(15)=wstrain
15765           weights_(16)=wvdwpp
15766           weights_(17)=wbond
15767           weights_(18)=scal14
15768           weights_(21)=wsccor
15769 ! FG Master broadcasts the WEIGHTS_ array
15770           call MPI_Bcast(weights_(1),n_ene,&
15771               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15772         else
15773 ! FG slaves receive the WEIGHTS array
15774           call MPI_Bcast(weights(1),n_ene,&
15775               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15776           wsc=weights(1)
15777           wscp=weights(2)
15778           welec=weights(3)
15779           wcorr=weights(4)
15780           wcorr5=weights(5)
15781           wcorr6=weights(6)
15782           wel_loc=weights(7)
15783           wturn3=weights(8)
15784           wturn4=weights(9)
15785           wturn6=weights(10)
15786           wang=weights(11)
15787           wscloc=weights(12)
15788           wtor=weights(13)
15789           wtor_d=weights(14)
15790           wstrain=weights(15)
15791           wvdwpp=weights(16)
15792           wbond=weights(17)
15793           scal14=weights(18)
15794           wsccor=weights(21)
15795         endif
15796         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15797           king,FG_COMM,IERR)
15798          time_Bcast=time_Bcast+MPI_Wtime()-time00
15799          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15800 !        call chainbuild_cart
15801 !        call int_from_cart1(.false.)
15802       endif
15803 !      write (iout,*) 'Processor',myrank,
15804 !     &  ' calling etotal_short ipot=',ipot
15805 !      call flush(iout)
15806 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15807 #endif
15808 !d    print *,'nnt=',nnt,' nct=',nct
15809 !
15810 !elwrite(iout,*)"in etotal long"
15811 ! Compute the side-chain and electrostatic interaction energy
15812 !
15813       goto (101,102,103,104,105,106) ipot
15814 ! Lennard-Jones potential.
15815   101 call elj_long(evdw)
15816 !d    print '(a)','Exit ELJ'
15817       goto 107
15818 ! Lennard-Jones-Kihara potential (shifted).
15819   102 call eljk_long(evdw)
15820       goto 107
15821 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15822   103 call ebp_long(evdw)
15823       goto 107
15824 ! Gay-Berne potential (shifted LJ, angular dependence).
15825   104 call egb_long(evdw)
15826       goto 107
15827 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15828   105 call egbv_long(evdw)
15829       goto 107
15830 ! Soft-sphere potential
15831   106 call e_softsphere(evdw)
15832 !
15833 ! Calculate electrostatic (H-bonding) energy of the main chain.
15834 !
15835   107 continue
15836       call vec_and_deriv
15837       if (ipot.lt.6) then
15838 #ifdef SPLITELE
15839          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15840              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15841              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15842              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15843 #else
15844          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15845              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15846              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15847              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15848 #endif
15849            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15850          else
15851             ees=0
15852             evdw1=0
15853             eel_loc=0
15854             eello_turn3=0
15855             eello_turn4=0
15856          endif
15857       else
15858 !        write (iout,*) "Soft-spheer ELEC potential"
15859         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15860          eello_turn4)
15861       endif
15862 !
15863 ! Calculate excluded-volume interaction energy between peptide groups
15864 ! and side chains.
15865 !
15866       if (ipot.lt.6) then
15867        if(wscp.gt.0d0) then
15868         call escp_long(evdw2,evdw2_14)
15869        else
15870         evdw2=0
15871         evdw2_14=0
15872        endif
15873       else
15874         call escp_soft_sphere(evdw2,evdw2_14)
15875       endif
15876 !
15877 ! 12/1/95 Multi-body terms
15878 !
15879       n_corr=0
15880       n_corr1=0
15881       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15882           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15883          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15884 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15885 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15886       else
15887          ecorr=0.0d0
15888          ecorr5=0.0d0
15889          ecorr6=0.0d0
15890          eturn6=0.0d0
15891       endif
15892       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15893          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15894       endif
15895 !
15896 ! If performing constraint dynamics, call the constraint energy
15897 !  after the equilibration time
15898       if(usampl.and.totT.gt.eq_time) then
15899          call EconstrQ
15900          call Econstr_back
15901       else
15902          Uconst=0.0d0
15903          Uconst_back=0.0d0
15904       endif
15905 !
15906 ! Sum the energies
15907 !
15908       do i=1,n_ene
15909         energia(i)=0.0d0
15910       enddo
15911       energia(1)=evdw
15912 #ifdef SCP14
15913       energia(2)=evdw2-evdw2_14
15914       energia(18)=evdw2_14
15915 #else
15916       energia(2)=evdw2
15917       energia(18)=0.0d0
15918 #endif
15919 #ifdef SPLITELE
15920       energia(3)=ees
15921       energia(16)=evdw1
15922 #else
15923       energia(3)=ees+evdw1
15924       energia(16)=0.0d0
15925 #endif
15926       energia(4)=ecorr
15927       energia(5)=ecorr5
15928       energia(6)=ecorr6
15929       energia(7)=eel_loc
15930       energia(8)=eello_turn3
15931       energia(9)=eello_turn4
15932       energia(10)=eturn6
15933       energia(20)=Uconst+Uconst_back
15934       call sum_energy(energia,.true.)
15935 !      write (iout,*) "Exit ETOTAL_LONG"
15936       call flush(iout)
15937       return
15938       end subroutine etotal_long
15939 !-----------------------------------------------------------------------------
15940       subroutine etotal_short(energia)
15941 !
15942 ! Compute the short-range fast-varying contributions to the energy
15943 !
15944 !      implicit real*8 (a-h,o-z)
15945 !      include 'DIMENSIONS'
15946 #ifndef ISNAN
15947       external proc_proc
15948 #ifdef WINPGI
15949 !MS$ATTRIBUTES C ::  proc_proc
15950 #endif
15951 #endif
15952 #ifdef MPI
15953       include "mpif.h"
15954       integer :: ierror,ierr
15955       real(kind=8),dimension(n_ene) :: weights_
15956       real(kind=8) :: time00
15957 #endif
15958 !      include 'COMMON.SETUP'
15959 !      include 'COMMON.IOUNITS'
15960 !      include 'COMMON.FFIELD'
15961 !      include 'COMMON.DERIV'
15962 !      include 'COMMON.INTERACT'
15963 !      include 'COMMON.SBRIDGE'
15964 !      include 'COMMON.CHAIN'
15965 !      include 'COMMON.VAR'
15966 !      include 'COMMON.LOCAL'
15967       real(kind=8),dimension(0:n_ene) :: energia
15968 !el local variables
15969       integer :: i,nres6
15970       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15971       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
15972       nres6=6*nres
15973
15974 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15975 !      call flush(iout)
15976       if (modecalc.eq.12.or.modecalc.eq.14) then
15977 #ifdef MPI
15978         if (fg_rank.eq.0) call int_from_cart1(.false.)
15979 #else
15980         call int_from_cart1(.false.)
15981 #endif
15982       endif
15983 #ifdef MPI
15984 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15985 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15986 !      call flush(iout)
15987       if (nfgtasks.gt.1) then
15988         time00=MPI_Wtime()
15989 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15990         if (fg_rank.eq.0) then
15991           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15992 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15993 !          call flush(iout)
15994 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15995 ! FG slaves as WEIGHTS array.
15996           weights_(1)=wsc
15997           weights_(2)=wscp
15998           weights_(3)=welec
15999           weights_(4)=wcorr
16000           weights_(5)=wcorr5
16001           weights_(6)=wcorr6
16002           weights_(7)=wel_loc
16003           weights_(8)=wturn3
16004           weights_(9)=wturn4
16005           weights_(10)=wturn6
16006           weights_(11)=wang
16007           weights_(12)=wscloc
16008           weights_(13)=wtor
16009           weights_(14)=wtor_d
16010           weights_(15)=wstrain
16011           weights_(16)=wvdwpp
16012           weights_(17)=wbond
16013           weights_(18)=scal14
16014           weights_(21)=wsccor
16015 ! FG Master broadcasts the WEIGHTS_ array
16016           call MPI_Bcast(weights_(1),n_ene,&
16017               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16018         else
16019 ! FG slaves receive the WEIGHTS array
16020           call MPI_Bcast(weights(1),n_ene,&
16021               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
16022           wsc=weights(1)
16023           wscp=weights(2)
16024           welec=weights(3)
16025           wcorr=weights(4)
16026           wcorr5=weights(5)
16027           wcorr6=weights(6)
16028           wel_loc=weights(7)
16029           wturn3=weights(8)
16030           wturn4=weights(9)
16031           wturn6=weights(10)
16032           wang=weights(11)
16033           wscloc=weights(12)
16034           wtor=weights(13)
16035           wtor_d=weights(14)
16036           wstrain=weights(15)
16037           wvdwpp=weights(16)
16038           wbond=weights(17)
16039           scal14=weights(18)
16040           wsccor=weights(21)
16041         endif
16042 !        write (iout,*),"Processor",myrank," BROADCAST weights"
16043         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
16044           king,FG_COMM,IERR)
16045 !        write (iout,*) "Processor",myrank," BROADCAST c"
16046         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
16047           king,FG_COMM,IERR)
16048 !        write (iout,*) "Processor",myrank," BROADCAST dc"
16049         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
16050           king,FG_COMM,IERR)
16051 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
16052         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
16053           king,FG_COMM,IERR)
16054 !        write (iout,*) "Processor",myrank," BROADCAST theta"
16055         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
16056           king,FG_COMM,IERR)
16057 !        write (iout,*) "Processor",myrank," BROADCAST phi"
16058         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
16059           king,FG_COMM,IERR)
16060 !        write (iout,*) "Processor",myrank," BROADCAST alph"
16061         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
16062           king,FG_COMM,IERR)
16063 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
16064         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
16065           king,FG_COMM,IERR)
16066 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
16067         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
16068           king,FG_COMM,IERR)
16069          time_Bcast=time_Bcast+MPI_Wtime()-time00
16070 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
16071       endif
16072 !      write (iout,*) 'Processor',myrank,
16073 !     &  ' calling etotal_short ipot=',ipot
16074 !      call flush(iout)
16075 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
16076 #endif
16077 !      call int_from_cart1(.false.)
16078 !
16079 ! Compute the side-chain and electrostatic interaction energy
16080 !
16081       goto (101,102,103,104,105,106) ipot
16082 ! Lennard-Jones potential.
16083   101 call elj_short(evdw)
16084 !d    print '(a)','Exit ELJ'
16085       goto 107
16086 ! Lennard-Jones-Kihara potential (shifted).
16087   102 call eljk_short(evdw)
16088       goto 107
16089 ! Berne-Pechukas potential (dilated LJ, angular dependence).
16090   103 call ebp_short(evdw)
16091       goto 107
16092 ! Gay-Berne potential (shifted LJ, angular dependence).
16093   104 call egb_short(evdw)
16094       goto 107
16095 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
16096   105 call egbv_short(evdw)
16097       goto 107
16098 ! Soft-sphere potential - already dealt with in the long-range part
16099   106 evdw=0.0d0
16100 !  106 call e_softsphere_short(evdw)
16101 !
16102 ! Calculate electrostatic (H-bonding) energy of the main chain.
16103 !
16104   107 continue
16105 !
16106 ! Calculate the short-range part of Evdwpp
16107 !
16108       call evdwpp_short(evdw1)
16109 !
16110 ! Calculate the short-range part of ESCp
16111 !
16112       if (ipot.lt.6) then
16113         call escp_short(evdw2,evdw2_14)
16114       endif
16115 !
16116 ! Calculate the bond-stretching energy
16117 !
16118       call ebond(estr)
16119 !
16120 ! Calculate the disulfide-bridge and other energy and the contributions
16121 ! from other distance constraints.
16122       call edis(ehpb)
16123 !
16124 ! Calculate the virtual-bond-angle energy.
16125 !
16126       call ebend(ebe,ethetacnstr)
16127 !
16128 ! Calculate the SC local energy.
16129 !
16130       call vec_and_deriv
16131       call esc(escloc)
16132 !
16133 ! Calculate the virtual-bond torsional energy.
16134 !
16135       call etor(etors,edihcnstr)
16136 !
16137 ! 6/23/01 Calculate double-torsional energy
16138 !
16139       call etor_d(etors_d)
16140 !
16141 ! 21/5/07 Calculate local sicdechain correlation energy
16142 !
16143       if (wsccor.gt.0.0d0) then
16144         call eback_sc_corr(esccor)
16145       else
16146         esccor=0.0d0
16147       endif
16148 !
16149 ! Put energy components into an array
16150 !
16151       do i=1,n_ene
16152         energia(i)=0.0d0
16153       enddo
16154       energia(1)=evdw
16155 #ifdef SCP14
16156       energia(2)=evdw2-evdw2_14
16157       energia(18)=evdw2_14
16158 #else
16159       energia(2)=evdw2
16160       energia(18)=0.0d0
16161 #endif
16162 #ifdef SPLITELE
16163       energia(16)=evdw1
16164 #else
16165       energia(3)=evdw1
16166 #endif
16167       energia(11)=ebe
16168       energia(12)=escloc
16169       energia(13)=etors
16170       energia(14)=etors_d
16171       energia(15)=ehpb
16172       energia(17)=estr
16173       energia(19)=edihcnstr
16174       energia(21)=esccor
16175 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
16176       call flush(iout)
16177       call sum_energy(energia,.true.)
16178 !      write (iout,*) "Exit ETOTAL_SHORT"
16179       call flush(iout)
16180       return
16181       end subroutine etotal_short
16182 !-----------------------------------------------------------------------------
16183 ! gnmr1.f
16184 !-----------------------------------------------------------------------------
16185       real(kind=8) function gnmr1(y,ymin,ymax)
16186 !      implicit none
16187       real(kind=8) :: y,ymin,ymax
16188       real(kind=8) :: wykl=4.0d0
16189       if (y.lt.ymin) then
16190         gnmr1=(ymin-y)**wykl/wykl
16191       else if (y.gt.ymax) then
16192         gnmr1=(y-ymax)**wykl/wykl
16193       else
16194         gnmr1=0.0d0
16195       endif
16196       return
16197       end function gnmr1
16198 !-----------------------------------------------------------------------------
16199       real(kind=8) function gnmr1prim(y,ymin,ymax)
16200 !      implicit none
16201       real(kind=8) :: y,ymin,ymax
16202       real(kind=8) :: wykl=4.0d0
16203       if (y.lt.ymin) then
16204         gnmr1prim=-(ymin-y)**(wykl-1)
16205       else if (y.gt.ymax) then
16206         gnmr1prim=(y-ymax)**(wykl-1)
16207       else
16208         gnmr1prim=0.0d0
16209       endif
16210       return
16211       end function gnmr1prim
16212 !----------------------------------------------------------------------------
16213       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16214       real(kind=8) y,ymin,ymax,sigma
16215       real(kind=8) wykl /4.0d0/
16216       if (y.lt.ymin) then
16217         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16218       else if (y.gt.ymax) then
16219         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16220       else
16221         rlornmr1=0.0d0
16222       endif
16223       return
16224       end function rlornmr1
16225 !------------------------------------------------------------------------------
16226       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16227       real(kind=8) y,ymin,ymax,sigma
16228       real(kind=8) wykl /4.0d0/
16229       if (y.lt.ymin) then
16230         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16231         ((ymin-y)**wykl+sigma**wykl)**2
16232       else if (y.gt.ymax) then
16233         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16234         ((y-ymax)**wykl+sigma**wykl)**2
16235       else
16236         rlornmr1prim=0.0d0
16237       endif
16238       return
16239       end function rlornmr1prim
16240
16241       real(kind=8) function harmonic(y,ymax)
16242 !      implicit none
16243       real(kind=8) :: y,ymax
16244       real(kind=8) :: wykl=2.0d0
16245       harmonic=(y-ymax)**wykl
16246       return
16247       end function harmonic
16248 !-----------------------------------------------------------------------------
16249       real(kind=8) function harmonicprim(y,ymax)
16250       real(kind=8) :: y,ymin,ymax
16251       real(kind=8) :: wykl=2.0d0
16252       harmonicprim=(y-ymax)*wykl
16253       return
16254       end function harmonicprim
16255 !-----------------------------------------------------------------------------
16256 ! gradient_p.F
16257 !-----------------------------------------------------------------------------
16258       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16259
16260       use io_base, only:intout,briefout
16261 !      implicit real*8 (a-h,o-z)
16262 !      include 'DIMENSIONS'
16263 !      include 'COMMON.CHAIN'
16264 !      include 'COMMON.DERIV'
16265 !      include 'COMMON.VAR'
16266 !      include 'COMMON.INTERACT'
16267 !      include 'COMMON.FFIELD'
16268 !      include 'COMMON.MD'
16269 !      include 'COMMON.IOUNITS'
16270       real(kind=8),external :: ufparm
16271       integer :: uiparm(1)
16272       real(kind=8) :: urparm(1)
16273       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16274       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16275       integer :: n,nf,ind,ind1,i,k,j
16276 !
16277 ! This subroutine calculates total internal coordinate gradient.
16278 ! Depending on the number of function evaluations, either whole energy
16279 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16280 ! internal coordinates are reevaluated or only the cartesian-in-internal
16281 ! coordinate derivatives are evaluated. The subroutine was designed to work
16282 ! with SUMSL.
16283 !
16284 !
16285       icg=mod(nf,2)+1
16286
16287 !d      print *,'grad',nf,icg
16288       if (nf-nfl+1) 20,30,40
16289    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16290 !    write (iout,*) 'grad 20'
16291       if (nf.eq.0) return
16292       goto 40
16293    30 call var_to_geom(n,x)
16294       call chainbuild
16295 !    write (iout,*) 'grad 30'
16296 !
16297 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16298 !
16299    40 call cartder
16300 !     write (iout,*) 'grad 40'
16301 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16302 !
16303 ! Convert the Cartesian gradient into internal-coordinate gradient.
16304 !
16305       ind=0
16306       ind1=0
16307       do i=1,nres-2
16308       gthetai=0.0D0
16309       gphii=0.0D0
16310       do j=i+1,nres-1
16311           ind=ind+1
16312 !         ind=indmat(i,j)
16313 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16314         do k=1,3
16315             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16316           enddo
16317         do k=1,3
16318           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16319           enddo
16320         enddo
16321       do j=i+1,nres-1
16322           ind1=ind1+1
16323 !         ind1=indmat(i,j)
16324 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16325         do k=1,3
16326           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16327           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16328           enddo
16329         enddo
16330       if (i.gt.1) g(i-1)=gphii
16331       if (n.gt.nphi) g(nphi+i)=gthetai
16332       enddo
16333       if (n.le.nphi+ntheta) goto 10
16334       do i=2,nres-1
16335       if (itype(i,1).ne.10) then
16336           galphai=0.0D0
16337         gomegai=0.0D0
16338         do k=1,3
16339           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16340           enddo
16341         do k=1,3
16342           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16343           enddo
16344           g(ialph(i,1))=galphai
16345         g(ialph(i,1)+nside)=gomegai
16346         endif
16347       enddo
16348 !
16349 ! Add the components corresponding to local energy terms.
16350 !
16351    10 continue
16352       do i=1,nvar
16353 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16354         g(i)=g(i)+gloc(i,icg)
16355       enddo
16356 ! Uncomment following three lines for diagnostics.
16357 !d    call intout
16358 !elwrite(iout,*) "in gradient after calling intout"
16359 !d    call briefout(0,0.0d0)
16360 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16361       return
16362       end subroutine gradient
16363 !-----------------------------------------------------------------------------
16364       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16365
16366       use comm_chu
16367 !      implicit real*8 (a-h,o-z)
16368 !      include 'DIMENSIONS'
16369 !      include 'COMMON.DERIV'
16370 !      include 'COMMON.IOUNITS'
16371 !      include 'COMMON.GEO'
16372       integer :: n,nf
16373 !el      integer :: jjj
16374 !el      common /chuju/ jjj
16375       real(kind=8) :: energia(0:n_ene)
16376       integer :: uiparm(1)
16377       real(kind=8) :: urparm(1)
16378       real(kind=8) :: f
16379       real(kind=8),external :: ufparm
16380       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16381 !     if (jjj.gt.0) then
16382 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16383 !     endif
16384       nfl=nf
16385       icg=mod(nf,2)+1
16386 !d      print *,'func',nf,nfl,icg
16387       call var_to_geom(n,x)
16388       call zerograd
16389       call chainbuild
16390 !d    write (iout,*) 'ETOTAL called from FUNC'
16391       call etotal(energia)
16392       call sum_gradient
16393       f=energia(0)
16394 !     if (jjj.gt.0) then
16395 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16396 !       write (iout,*) 'f=',etot
16397 !       jjj=0
16398 !     endif
16399       return
16400       end subroutine func
16401 !-----------------------------------------------------------------------------
16402       subroutine cartgrad
16403 !      implicit real*8 (a-h,o-z)
16404 !      include 'DIMENSIONS'
16405       use energy_data
16406       use MD_data, only: totT,usampl,eq_time
16407 #ifdef MPI
16408       include 'mpif.h'
16409 #endif
16410 !      include 'COMMON.CHAIN'
16411 !      include 'COMMON.DERIV'
16412 !      include 'COMMON.VAR'
16413 !      include 'COMMON.INTERACT'
16414 !      include 'COMMON.FFIELD'
16415 !      include 'COMMON.MD'
16416 !      include 'COMMON.IOUNITS'
16417 !      include 'COMMON.TIME1'
16418 !
16419       integer :: i,j
16420
16421 ! This subrouting calculates total Cartesian coordinate gradient.
16422 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16423 !
16424 !#define DEBUG
16425 #ifdef TIMING
16426       time00=MPI_Wtime()
16427 #endif
16428       icg=1
16429       call sum_gradient
16430 #ifdef TIMING
16431 #endif
16432 !#define DEBUG
16433 !el      write (iout,*) "After sum_gradient"
16434 #ifdef DEBUG
16435 !el      write (iout,*) "After sum_gradient"
16436       do i=1,nres-1
16437         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16438         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16439       enddo
16440 #endif
16441 !#undef DEBUG
16442 ! If performing constraint dynamics, add the gradients of the constraint energy
16443       if(usampl.and.totT.gt.eq_time) then
16444          do i=1,nct
16445            do j=1,3
16446              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
16447              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
16448            enddo
16449          enddo
16450          do i=1,nres-3
16451            gloc(i,icg)=gloc(i,icg)+dugamma(i)
16452          enddo
16453          do i=1,nres-2
16454            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
16455          enddo
16456       endif
16457 !elwrite (iout,*) "After sum_gradient"
16458 #ifdef TIMING
16459       time01=MPI_Wtime()
16460 #endif
16461       call intcartderiv
16462 !elwrite (iout,*) "After sum_gradient"
16463 #ifdef TIMING
16464       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
16465 #endif
16466 !     call checkintcartgrad
16467 !     write(iout,*) 'calling int_to_cart'
16468 !#define DEBUG
16469 #ifdef DEBUG
16470       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
16471 #endif
16472       do i=0,nct
16473         do j=1,3
16474           gcart(j,i)=gradc(j,i,icg)
16475           gxcart(j,i)=gradx(j,i,icg)
16476 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
16477         enddo
16478 #ifdef DEBUG
16479         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
16480           (gxcart(j,i),j=1,3),gloc(i,icg)
16481 #endif
16482       enddo
16483 #ifdef TIMING
16484       time01=MPI_Wtime()
16485 #endif
16486 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16487       call int_to_cart
16488 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16489
16490 #ifdef TIMING
16491             time_inttocart=time_inttocart+MPI_Wtime()-time01
16492 #endif
16493 #ifdef DEBUG
16494             write (iout,*) "gcart and gxcart after int_to_cart"
16495             do i=0,nres-1
16496             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16497                 (gxcart(j,i),j=1,3)
16498             enddo
16499 #endif
16500 !#undef DEBUG
16501 #ifdef CARGRAD
16502 #ifdef DEBUG
16503             write (iout,*) "CARGRAD"
16504 #endif
16505             do i=nres,0,-1
16506             do j=1,3
16507               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16508       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16509             enddo
16510       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16511       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16512             enddo
16513       ! Correction: dummy residues
16514             if (nnt.gt.1) then
16515               do j=1,3
16516       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16517                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16518               enddo
16519             endif
16520             if (nct.lt.nres) then
16521               do j=1,3
16522       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16523                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16524               enddo
16525             endif
16526 #endif
16527 #ifdef TIMING
16528             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16529 #endif
16530 !#undef DEBUG
16531             return
16532             end subroutine cartgrad
16533       !-----------------------------------------------------------------------------
16534             subroutine zerograd
16535       !      implicit real*8 (a-h,o-z)
16536       !      include 'DIMENSIONS'
16537       !      include 'COMMON.DERIV'
16538       !      include 'COMMON.CHAIN'
16539       !      include 'COMMON.VAR'
16540       !      include 'COMMON.MD'
16541       !      include 'COMMON.SCCOR'
16542       !
16543       !el local variables
16544             integer :: i,j,intertyp,k
16545       ! Initialize Cartesian-coordinate gradient
16546       !
16547       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16548       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16549
16550       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16551       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16552       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16553       !      allocate(gradcorr_long(3,nres))
16554       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16555       !      allocate(gcorr6_turn_long(3,nres))
16556       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16557
16558       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16559
16560       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16561       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16562
16563       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16564       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16565
16566       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16567       !      allocate(gscloc(3,nres)) !(3,maxres)
16568       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16569
16570
16571
16572       !      common /deriv_scloc/
16573       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16574       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16575       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
16576       !      common /mpgrad/
16577       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16578
16579
16580
16581       !          gradc(j,i,icg)=0.0d0
16582       !          gradx(j,i,icg)=0.0d0
16583
16584       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16585       !elwrite(iout,*) "icg",icg
16586             do i=-1,nres
16587             do j=1,3
16588               gvdwx(j,i)=0.0D0
16589               gradx_scp(j,i)=0.0D0
16590               gvdwc(j,i)=0.0D0
16591               gvdwc_scp(j,i)=0.0D0
16592               gvdwc_scpp(j,i)=0.0d0
16593               gelc(j,i)=0.0D0
16594               gelc_long(j,i)=0.0D0
16595               gradb(j,i)=0.0d0
16596               gradbx(j,i)=0.0d0
16597               gvdwpp(j,i)=0.0d0
16598               gel_loc(j,i)=0.0d0
16599               gel_loc_long(j,i)=0.0d0
16600               ghpbc(j,i)=0.0D0
16601               ghpbx(j,i)=0.0D0
16602               gcorr3_turn(j,i)=0.0d0
16603               gcorr4_turn(j,i)=0.0d0
16604               gradcorr(j,i)=0.0d0
16605               gradcorr_long(j,i)=0.0d0
16606               gradcorr5_long(j,i)=0.0d0
16607               gradcorr6_long(j,i)=0.0d0
16608               gcorr6_turn_long(j,i)=0.0d0
16609               gradcorr5(j,i)=0.0d0
16610               gradcorr6(j,i)=0.0d0
16611               gcorr6_turn(j,i)=0.0d0
16612               gsccorc(j,i)=0.0d0
16613               gsccorx(j,i)=0.0d0
16614               gradc(j,i,icg)=0.0d0
16615               gradx(j,i,icg)=0.0d0
16616               gscloc(j,i)=0.0d0
16617               gsclocx(j,i)=0.0d0
16618               gliptran(j,i)=0.0d0
16619               gliptranx(j,i)=0.0d0
16620               gliptranc(j,i)=0.0d0
16621               gshieldx(j,i)=0.0d0
16622               gshieldc(j,i)=0.0d0
16623               gshieldc_loc(j,i)=0.0d0
16624               gshieldx_ec(j,i)=0.0d0
16625               gshieldc_ec(j,i)=0.0d0
16626               gshieldc_loc_ec(j,i)=0.0d0
16627               gshieldx_t3(j,i)=0.0d0
16628               gshieldc_t3(j,i)=0.0d0
16629               gshieldc_loc_t3(j,i)=0.0d0
16630               gshieldx_t4(j,i)=0.0d0
16631               gshieldc_t4(j,i)=0.0d0
16632               gshieldc_loc_t4(j,i)=0.0d0
16633               gshieldx_ll(j,i)=0.0d0
16634               gshieldc_ll(j,i)=0.0d0
16635               gshieldc_loc_ll(j,i)=0.0d0
16636               gg_tube(j,i)=0.0d0
16637               gg_tube_sc(j,i)=0.0d0
16638               gradafm(j,i)=0.0d0
16639               gradb_nucl(j,i)=0.0d0
16640               gradbx_nucl(j,i)=0.0d0
16641               gvdwpp_nucl(j,i)=0.0d0
16642               gvdwpp(j,i)=0.0d0
16643               gelpp(j,i)=0.0d0
16644               gvdwpsb(j,i)=0.0d0
16645               gvdwpsb1(j,i)=0.0d0
16646               gvdwsbc(j,i)=0.0d0
16647               gvdwsbx(j,i)=0.0d0
16648               gelsbc(j,i)=0.0d0
16649               gradcorr_nucl(j,i)=0.0d0
16650               gradcorr3_nucl(j,i)=0.0d0
16651               gradxorr_nucl(j,i)=0.0d0
16652               gradxorr3_nucl(j,i)=0.0d0
16653               gelsbx(j,i)=0.0d0
16654               gsbloc(j,i)=0.0d0
16655               gsblocx(j,i)=0.0d0
16656               gradpepcat(j,i)=0.0d0
16657               gradpepcatx(j,i)=0.0d0
16658               gradcatcat(j,i)=0.0d0
16659               gvdwx_scbase(j,i)=0.0d0
16660               gvdwc_scbase(j,i)=0.0d0
16661               gvdwx_pepbase(j,i)=0.0d0
16662               gvdwc_pepbase(j,i)=0.0d0
16663               gvdwx_scpho(j,i)=0.0d0
16664               gvdwc_scpho(j,i)=0.0d0
16665               gvdwc_peppho(j,i)=0.0d0
16666             enddo
16667              enddo
16668             do i=0,nres
16669             do j=1,3
16670               do intertyp=1,3
16671                gloc_sc(intertyp,i,icg)=0.0d0
16672               enddo
16673             enddo
16674             enddo
16675             do i=1,nres
16676              do j=1,maxcontsshi
16677              shield_list(j,i)=0
16678             do k=1,3
16679       !C           print *,i,j,k
16680                grad_shield_side(k,j,i)=0.0d0
16681                grad_shield_loc(k,j,i)=0.0d0
16682              enddo
16683              enddo
16684              ishield_list(i)=0
16685             enddo
16686
16687       !
16688       ! Initialize the gradient of local energy terms.
16689       !
16690       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
16691       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16692       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16693       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
16694       !      allocate(gel_loc_turn3(nres))
16695       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16696       !      allocate(gsccor_loc(nres))      !(maxres)
16697
16698             do i=1,4*nres
16699             gloc(i,icg)=0.0D0
16700             enddo
16701             do i=1,nres
16702             gel_loc_loc(i)=0.0d0
16703             gcorr_loc(i)=0.0d0
16704             g_corr5_loc(i)=0.0d0
16705             g_corr6_loc(i)=0.0d0
16706             gel_loc_turn3(i)=0.0d0
16707             gel_loc_turn4(i)=0.0d0
16708             gel_loc_turn6(i)=0.0d0
16709             gsccor_loc(i)=0.0d0
16710             enddo
16711       ! initialize gcart and gxcart
16712       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16713             do i=0,nres
16714             do j=1,3
16715               gcart(j,i)=0.0d0
16716               gxcart(j,i)=0.0d0
16717             enddo
16718             enddo
16719             return
16720             end subroutine zerograd
16721       !-----------------------------------------------------------------------------
16722             real(kind=8) function fdum()
16723             fdum=0.0D0
16724             return
16725             end function fdum
16726       !-----------------------------------------------------------------------------
16727       ! intcartderiv.F
16728       !-----------------------------------------------------------------------------
16729             subroutine intcartderiv
16730       !      implicit real*8 (a-h,o-z)
16731       !      include 'DIMENSIONS'
16732 #ifdef MPI
16733             include 'mpif.h'
16734 #endif
16735       !      include 'COMMON.SETUP'
16736       !      include 'COMMON.CHAIN'
16737       !      include 'COMMON.VAR'
16738       !      include 'COMMON.GEO'
16739       !      include 'COMMON.INTERACT'
16740       !      include 'COMMON.DERIV'
16741       !      include 'COMMON.IOUNITS'
16742       !      include 'COMMON.LOCAL'
16743       !      include 'COMMON.SCCOR'
16744             real(kind=8) :: pi4,pi34
16745             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
16746             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
16747                       dcosomega,dsinomega !(3,3,maxres)
16748             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
16749
16750             integer :: i,j,k
16751             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
16752                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
16753                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
16754                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
16755             integer :: nres2
16756             nres2=2*nres
16757
16758       !el from module energy-------------
16759       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
16760       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
16761       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
16762
16763       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
16764       !el      allocate(dsintau(3,3,3,0:nres2))
16765       !el      allocate(dtauangle(3,3,3,0:nres2))
16766       !el      allocate(domicron(3,2,2,0:nres2))
16767       !el      allocate(dcosomicron(3,2,2,0:nres2))
16768
16769
16770
16771 #if defined(MPI) && defined(PARINTDER)
16772             if (nfgtasks.gt.1 .and. me.eq.king) &
16773             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
16774 #endif
16775             pi4 = 0.5d0*pipol
16776             pi34 = 3*pi4
16777
16778       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
16779       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
16780
16781       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
16782             do i=1,nres
16783             do j=1,3
16784               dtheta(j,1,i)=0.0d0
16785               dtheta(j,2,i)=0.0d0
16786               dphi(j,1,i)=0.0d0
16787               dphi(j,2,i)=0.0d0
16788               dphi(j,3,i)=0.0d0
16789             enddo
16790             enddo
16791       ! Derivatives of theta's
16792 #if defined(MPI) && defined(PARINTDER)
16793       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16794             do i=max0(ithet_start-1,3),ithet_end
16795 #else
16796             do i=3,nres
16797 #endif
16798             cost=dcos(theta(i))
16799             sint=sqrt(1-cost*cost)
16800             do j=1,3
16801               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
16802               vbld(i-1)
16803               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
16804               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
16805               vbld(i)
16806               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
16807             enddo
16808             enddo
16809 #if defined(MPI) && defined(PARINTDER)
16810       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16811             do i=max0(ithet_start-1,3),ithet_end
16812 #else
16813             do i=3,nres
16814 #endif
16815             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
16816             cost1=dcos(omicron(1,i))
16817             sint1=sqrt(1-cost1*cost1)
16818             cost2=dcos(omicron(2,i))
16819             sint2=sqrt(1-cost2*cost2)
16820              do j=1,3
16821       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
16822               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
16823               cost1*dc_norm(j,i-2))/ &
16824               vbld(i-1)
16825               domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
16826               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
16827               +cost1*(dc_norm(j,i-1+nres)))/ &
16828               vbld(i-1+nres)
16829               domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
16830       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
16831       !C Looks messy but better than if in loop
16832               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
16833               +cost2*dc_norm(j,i-1))/ &
16834               vbld(i)
16835               domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
16836               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16837                +cost2*(-dc_norm(j,i-1+nres)))/ &
16838               vbld(i-1+nres)
16839       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
16840               domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
16841             enddo
16842              endif
16843             enddo
16844       !elwrite(iout,*) "after vbld write"
16845       ! Derivatives of phi:
16846       ! If phi is 0 or 180 degrees, then the formulas
16847       ! have to be derived by power series expansion of the
16848       ! conventional formulas around 0 and 180.
16849 #ifdef PARINTDER
16850             do i=iphi1_start,iphi1_end
16851 #else
16852             do i=4,nres
16853 #endif
16854       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
16855       ! the conventional case
16856             sint=dsin(theta(i))
16857             sint1=dsin(theta(i-1))
16858             sing=dsin(phi(i))
16859             cost=dcos(theta(i))
16860             cost1=dcos(theta(i-1))
16861             cosg=dcos(phi(i))
16862             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16863             fac0=1.0d0/(sint1*sint)
16864             fac1=cost*fac0
16865             fac2=cost1*fac0
16866             fac3=cosg*cost1/(sint1*sint1)
16867             fac4=cosg*cost/(sint*sint)
16868       !    Obtaining the gamma derivatives from sine derivative
16869              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16870                phi(i).gt.pi34.and.phi(i).le.pi.or. &
16871                phi(i).ge.-pi.and.phi(i).le.-pi34) then
16872              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16873              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16874              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16875              do j=1,3
16876                 ctgt=cost/sint
16877                 ctgt1=cost1/sint1
16878                 cosg_inv=1.0d0/cosg
16879                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16880                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16881                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16882                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16883                 dsinphi(j,2,i)= &
16884                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16885                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16886                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16887                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16888                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16889       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16890                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16891                 endif
16892       ! Bug fixed 3/24/05 (AL)
16893              enddo
16894       !   Obtaining the gamma derivatives from cosine derivative
16895             else
16896                do j=1,3
16897                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16898                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16899                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16900                dc_norm(j,i-3))/vbld(i-2)
16901                dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
16902                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16903                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16904                dcostheta(j,1,i)
16905                dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
16906                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16907                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16908                dc_norm(j,i-1))/vbld(i)
16909                dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
16910 !#define DEBUG
16911 #ifdef DEBUG
16912                write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
16913 #endif
16914 !#undef DEBUG
16915                endif
16916              enddo
16917             endif
16918             enddo
16919       !alculate derivative of Tauangle
16920 #ifdef PARINTDER
16921             do i=itau_start,itau_end
16922 #else
16923             do i=3,nres
16924       !elwrite(iout,*) " vecpr",i,nres
16925 #endif
16926              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16927       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
16928       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
16929       !c dtauangle(j,intertyp,dervityp,residue number)
16930       !c INTERTYP=1 SC...Ca...Ca..Ca
16931       ! the conventional case
16932             sint=dsin(theta(i))
16933             sint1=dsin(omicron(2,i-1))
16934             sing=dsin(tauangle(1,i))
16935             cost=dcos(theta(i))
16936             cost1=dcos(omicron(2,i-1))
16937             cosg=dcos(tauangle(1,i))
16938       !elwrite(iout,*) " vecpr5",i,nres
16939             do j=1,3
16940       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16941       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16942             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16943       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16944             enddo
16945             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16946             fac0=1.0d0/(sint1*sint)
16947             fac1=cost*fac0
16948             fac2=cost1*fac0
16949             fac3=cosg*cost1/(sint1*sint1)
16950             fac4=cosg*cost/(sint*sint)
16951       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16952       !    Obtaining the gamma derivatives from sine derivative
16953              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16954                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16955                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16956              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16957              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16958              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16959             do j=1,3
16960                 ctgt=cost/sint
16961                 ctgt1=cost1/sint1
16962                 cosg_inv=1.0d0/cosg
16963                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16964              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16965              *vbld_inv(i-2+nres)
16966                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16967                 dsintau(j,1,2,i)= &
16968                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16969                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16970       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16971                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16972       ! Bug fixed 3/24/05 (AL)
16973                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16974                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16975       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16976                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16977              enddo
16978       !   Obtaining the gamma derivatives from cosine derivative
16979             else
16980                do j=1,3
16981                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16982                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16983                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16984                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16985                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16986                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16987                dcostheta(j,1,i)
16988                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16989                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16990                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16991                dc_norm(j,i-1))/vbld(i)
16992                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16993       !         write (iout,*) "else",i
16994              enddo
16995             endif
16996       !        do k=1,3
16997       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16998       !        enddo
16999             enddo
17000       !C Second case Ca...Ca...Ca...SC
17001 #ifdef PARINTDER
17002             do i=itau_start,itau_end
17003 #else
17004             do i=4,nres
17005 #endif
17006              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17007               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
17008       ! the conventional case
17009             sint=dsin(omicron(1,i))
17010             sint1=dsin(theta(i-1))
17011             sing=dsin(tauangle(2,i))
17012             cost=dcos(omicron(1,i))
17013             cost1=dcos(theta(i-1))
17014             cosg=dcos(tauangle(2,i))
17015       !        do j=1,3
17016       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17017       !        enddo
17018             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
17019             fac0=1.0d0/(sint1*sint)
17020             fac1=cost*fac0
17021             fac2=cost1*fac0
17022             fac3=cosg*cost1/(sint1*sint1)
17023             fac4=cosg*cost/(sint*sint)
17024       !    Obtaining the gamma derivatives from sine derivative
17025              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
17026                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
17027                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
17028              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
17029              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
17030              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
17031             do j=1,3
17032                 ctgt=cost/sint
17033                 ctgt1=cost1/sint1
17034                 cosg_inv=1.0d0/cosg
17035                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
17036                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
17037       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
17038       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
17039                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
17040                 dsintau(j,2,2,i)= &
17041                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
17042                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17043       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
17044       !     & sing*ctgt*domicron(j,1,2,i),
17045       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17046                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
17047       ! Bug fixed 3/24/05 (AL)
17048                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17049                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
17050       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17051                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
17052              enddo
17053       !   Obtaining the gamma derivatives from cosine derivative
17054             else
17055                do j=1,3
17056                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
17057                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17058                dc_norm(j,i-3))/vbld(i-2)
17059                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
17060                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
17061                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
17062                dcosomicron(j,1,1,i)
17063                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
17064                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17065                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
17066                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17067                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
17068       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
17069              enddo
17070             endif
17071             enddo
17072
17073       !CC third case SC...Ca...Ca...SC
17074 #ifdef PARINTDER
17075
17076             do i=itau_start,itau_end
17077 #else
17078             do i=3,nres
17079 #endif
17080       ! the conventional case
17081             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
17082             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
17083             sint=dsin(omicron(1,i))
17084             sint1=dsin(omicron(2,i-1))
17085             sing=dsin(tauangle(3,i))
17086             cost=dcos(omicron(1,i))
17087             cost1=dcos(omicron(2,i-1))
17088             cosg=dcos(tauangle(3,i))
17089             do j=1,3
17090             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
17091       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
17092             enddo
17093             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
17094             fac0=1.0d0/(sint1*sint)
17095             fac1=cost*fac0
17096             fac2=cost1*fac0
17097             fac3=cosg*cost1/(sint1*sint1)
17098             fac4=cosg*cost/(sint*sint)
17099       !    Obtaining the gamma derivatives from sine derivative
17100              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
17101                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
17102                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
17103              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
17104              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
17105              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
17106             do j=1,3
17107                 ctgt=cost/sint
17108                 ctgt1=cost1/sint1
17109                 cosg_inv=1.0d0/cosg
17110                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
17111                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
17112                   *vbld_inv(i-2+nres)
17113                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
17114                 dsintau(j,3,2,i)= &
17115                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
17116                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
17117                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
17118       ! Bug fixed 3/24/05 (AL)
17119                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
17120                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
17121                   *vbld_inv(i-1+nres)
17122       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
17123                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
17124              enddo
17125       !   Obtaining the gamma derivatives from cosine derivative
17126             else
17127                do j=1,3
17128                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
17129                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
17130                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
17131                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
17132                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
17133                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
17134                dcosomicron(j,1,1,i)
17135                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
17136                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
17137                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
17138                dc_norm(j,i-1+nres))/vbld(i-1+nres)
17139                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
17140       !          write(iout,*) "else",i
17141              enddo
17142             endif
17143             enddo
17144
17145 #ifdef CRYST_SC
17146       !   Derivatives of side-chain angles alpha and omega
17147 #if defined(MPI) && defined(PARINTDER)
17148             do i=ibond_start,ibond_end
17149 #else
17150             do i=2,nres-1
17151 #endif
17152               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
17153                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
17154                  fac6=fac5/vbld(i)
17155                  fac7=fac5*fac5
17156                  fac8=fac5/vbld(i+1)
17157                  fac9=fac5/vbld(i+nres)
17158                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
17159                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
17160                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
17161                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
17162                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
17163                  sina=sqrt(1-cosa*cosa)
17164                  sino=dsin(omeg(i))
17165       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
17166                  do j=1,3
17167                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
17168                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
17169                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
17170                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
17171                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
17172                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
17173                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
17174                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
17175                   vbld(i+nres))
17176                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
17177                 enddo
17178       ! obtaining the derivatives of omega from sines
17179                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
17180                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
17181                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
17182                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
17183                    dsin(theta(i+1)))
17184                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
17185                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
17186                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
17187                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
17188                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
17189                    coso_inv=1.0d0/dcos(omeg(i))
17190                    do j=1,3
17191                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
17192                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
17193                    (sino*dc_norm(j,i-1))/vbld(i)
17194                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
17195                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
17196                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
17197                    -sino*dc_norm(j,i)/vbld(i+1)
17198                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
17199                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
17200                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
17201                    vbld(i+nres)
17202                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
17203                   enddo
17204                else
17205       !   obtaining the derivatives of omega from cosines
17206                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
17207                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
17208                  fac12=fac10*sina
17209                  fac13=fac12*fac12
17210                  fac14=sina*sina
17211                  do j=1,3
17212                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
17213                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
17214                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
17215                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
17216                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17217                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17218                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17219                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17220                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17221                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17222                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17223                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17224                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17225                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17226                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17227                 enddo
17228               endif
17229              else
17230                do j=1,3
17231                  do k=1,3
17232                    dalpha(k,j,i)=0.0d0
17233                    domega(k,j,i)=0.0d0
17234                  enddo
17235                enddo
17236              endif
17237              enddo
17238 #endif
17239 #if defined(MPI) && defined(PARINTDER)
17240             if (nfgtasks.gt.1) then
17241 #ifdef DEBUG
17242       !d      write (iout,*) "Gather dtheta"
17243       !d      call flush(iout)
17244             write (iout,*) "dtheta before gather"
17245             do i=1,nres
17246             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17247             enddo
17248 #endif
17249             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17250             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17251             king,FG_COMM,IERROR)
17252 !#define DEBUG
17253 #ifdef DEBUG
17254       !d      write (iout,*) "Gather dphi"
17255       !d      call flush(iout)
17256             write (iout,*) "dphi before gather"
17257             do i=1,nres
17258             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17259             enddo
17260 #endif
17261 !#undef DEBUG
17262             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17263             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17264             king,FG_COMM,IERROR)
17265       !d      write (iout,*) "Gather dalpha"
17266       !d      call flush(iout)
17267 #ifdef CRYST_SC
17268             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17269             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17270             king,FG_COMM,IERROR)
17271       !d      write (iout,*) "Gather domega"
17272       !d      call flush(iout)
17273             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17274             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17275             king,FG_COMM,IERROR)
17276 #endif
17277             endif
17278 #endif
17279 !#define DEBUG
17280 #ifdef DEBUG
17281             write (iout,*) "dtheta after gather"
17282             do i=1,nres
17283             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17284             enddo
17285             write (iout,*) "dphi after gather"
17286             do i=1,nres
17287             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17288             enddo
17289             write (iout,*) "dalpha after gather"
17290             do i=1,nres
17291             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17292             enddo
17293             write (iout,*) "domega after gather"
17294             do i=1,nres
17295             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17296             enddo
17297 #endif
17298 !#undef DEBUG
17299             return
17300             end subroutine intcartderiv
17301       !-----------------------------------------------------------------------------
17302             subroutine checkintcartgrad
17303       !      implicit real*8 (a-h,o-z)
17304       !      include 'DIMENSIONS'
17305 #ifdef MPI
17306             include 'mpif.h'
17307 #endif
17308       !      include 'COMMON.CHAIN'
17309       !      include 'COMMON.VAR'
17310       !      include 'COMMON.GEO'
17311       !      include 'COMMON.INTERACT'
17312       !      include 'COMMON.DERIV'
17313       !      include 'COMMON.IOUNITS'
17314       !      include 'COMMON.SETUP'
17315             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17316             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17317             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17318             real(kind=8),dimension(3) :: dc_norm_s
17319             real(kind=8) :: aincr=1.0d-5
17320             integer :: i,j
17321             real(kind=8) :: dcji
17322             do i=1,nres
17323             phi_s(i)=phi(i)
17324             theta_s(i)=theta(i)
17325             alph_s(i)=alph(i)
17326             omeg_s(i)=omeg(i)
17327             enddo
17328       ! Check theta gradient
17329             write (iout,*) &
17330              "Analytical (upper) and numerical (lower) gradient of theta"
17331             write (iout,*)
17332             do i=3,nres
17333             do j=1,3
17334               dcji=dc(j,i-2)
17335               dc(j,i-2)=dcji+aincr
17336               call chainbuild_cart
17337               call int_from_cart1(.false.)
17338           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17339           dc(j,i-2)=dcji
17340           dcji=dc(j,i-1)
17341           dc(j,i-1)=dc(j,i-1)+aincr
17342           call chainbuild_cart
17343           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17344           dc(j,i-1)=dcji
17345         enddo
17346 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17347 !el          (dtheta(j,2,i),j=1,3)
17348 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17349 !el          (dthetanum(j,2,i),j=1,3)
17350 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17351 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17352 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17353 !el        write (iout,*)
17354       enddo
17355 ! Check gamma gradient
17356       write (iout,*) &
17357        "Analytical (upper) and numerical (lower) gradient of gamma"
17358       do i=4,nres
17359         do j=1,3
17360           dcji=dc(j,i-3)
17361           dc(j,i-3)=dcji+aincr
17362           call chainbuild_cart
17363           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17364               dc(j,i-3)=dcji
17365           dcji=dc(j,i-2)
17366           dc(j,i-2)=dcji+aincr
17367           call chainbuild_cart
17368           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17369           dc(j,i-2)=dcji
17370           dcji=dc(j,i-1)
17371           dc(j,i-1)=dc(j,i-1)+aincr
17372           call chainbuild_cart
17373           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17374           dc(j,i-1)=dcji
17375         enddo
17376 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17377 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17378 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17379 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17380 !el        write (iout,'(5x,3(3f10.5,5x))') &
17381 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17382 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17383 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17384 !el        write (iout,*)
17385       enddo
17386 ! Check alpha gradient
17387       write (iout,*) &
17388        "Analytical (upper) and numerical (lower) gradient of alpha"
17389       do i=2,nres-1
17390        if(itype(i,1).ne.10) then
17391                  do j=1,3
17392                   dcji=dc(j,i-1)
17393                    dc(j,i-1)=dcji+aincr
17394               call chainbuild_cart
17395               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17396                  /aincr
17397                   dc(j,i-1)=dcji
17398               dcji=dc(j,i)
17399               dc(j,i)=dcji+aincr
17400               call chainbuild_cart
17401               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17402                  /aincr
17403               dc(j,i)=dcji
17404               dcji=dc(j,i+nres)
17405               dc(j,i+nres)=dc(j,i+nres)+aincr
17406               call chainbuild_cart
17407               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17408                  /aincr
17409              dc(j,i+nres)=dcji
17410             enddo
17411           endif
17412 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17413 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17414 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17415 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17416 !el        write (iout,'(5x,3(3f10.5,5x))') &
17417 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17418 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17419 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17420 !el        write (iout,*)
17421       enddo
17422 !     Check omega gradient
17423       write (iout,*) &
17424        "Analytical (upper) and numerical (lower) gradient of omega"
17425       do i=2,nres-1
17426        if(itype(i,1).ne.10) then
17427                  do j=1,3
17428                   dcji=dc(j,i-1)
17429                    dc(j,i-1)=dcji+aincr
17430               call chainbuild_cart
17431               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
17432                  /aincr
17433                   dc(j,i-1)=dcji
17434               dcji=dc(j,i)
17435               dc(j,i)=dcji+aincr
17436               call chainbuild_cart
17437               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
17438                  /aincr
17439               dc(j,i)=dcji
17440               dcji=dc(j,i+nres)
17441               dc(j,i+nres)=dc(j,i+nres)+aincr
17442               call chainbuild_cart
17443               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
17444                  /aincr
17445              dc(j,i+nres)=dcji
17446             enddo
17447           endif
17448 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
17449 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
17450 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
17451 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
17452 !el        write (iout,'(5x,3(3f10.5,5x))') &
17453 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
17454 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
17455 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
17456 !el        write (iout,*)
17457       enddo
17458       return
17459       end subroutine checkintcartgrad
17460 !-----------------------------------------------------------------------------
17461 ! q_measure.F
17462 !-----------------------------------------------------------------------------
17463       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
17464 !      implicit real*8 (a-h,o-z)
17465 !      include 'DIMENSIONS'
17466 !      include 'COMMON.IOUNITS'
17467 !      include 'COMMON.CHAIN'
17468 !      include 'COMMON.INTERACT'
17469 !      include 'COMMON.VAR'
17470       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
17471       integer :: kkk,nsep=3
17472       real(kind=8) :: qm      !dist,
17473       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
17474       logical :: lprn=.false.
17475       logical :: flag
17476 !      real(kind=8) :: sigm,x
17477
17478 !el      sigm(x)=0.25d0*x     ! local function
17479       qqmax=1.0d10
17480       do kkk=1,nperm
17481       qq = 0.0d0
17482       nl=0
17483        if(flag) then
17484         do il=seg1+nsep,seg2
17485           do jl=seg1,il-nsep
17486             nl=nl+1
17487             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
17488                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
17489                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17490             dij=dist(il,jl)
17491             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17492             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17493               nl=nl+1
17494               d0ijCM=dsqrt( &
17495                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17496                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17497                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17498               dijCM=dist(il+nres,jl+nres)
17499               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17500             endif
17501             qq = qq+qqij+qqijCM
17502           enddo
17503         enddo
17504         qq = qq/nl
17505       else
17506       do il=seg1,seg2
17507         if((seg3-il).lt.3) then
17508              secseg=il+3
17509         else
17510              secseg=seg3
17511         endif
17512           do jl=secseg,seg4
17513             nl=nl+1
17514             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17515                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17516                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17517             dij=dist(il,jl)
17518             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17519             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17520               nl=nl+1
17521               d0ijCM=dsqrt( &
17522                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17523                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17524                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17525               dijCM=dist(il+nres,jl+nres)
17526               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17527             endif
17528             qq = qq+qqij+qqijCM
17529           enddo
17530         enddo
17531       qq = qq/nl
17532       endif
17533       if (qqmax.le.qq) qqmax=qq
17534       enddo
17535       qwolynes=1.0d0-qqmax
17536       return
17537       end function qwolynes
17538 !-----------------------------------------------------------------------------
17539       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17540 !      implicit real*8 (a-h,o-z)
17541 !      include 'DIMENSIONS'
17542 !      include 'COMMON.IOUNITS'
17543 !      include 'COMMON.CHAIN'
17544 !      include 'COMMON.INTERACT'
17545 !      include 'COMMON.VAR'
17546 !      include 'COMMON.MD'
17547       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17548       integer :: nsep=3, kkk
17549 !el      real(kind=8) :: dist
17550       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17551       logical :: lprn=.false.
17552       logical :: flag
17553       real(kind=8) :: sim,dd0,fac,ddqij
17554 !el      sigm(x)=0.25d0*x           ! local function
17555       do kkk=1,nperm
17556       do i=0,nres
17557         do j=1,3
17558           dqwol(j,i)=0.0d0
17559           dxqwol(j,i)=0.0d0
17560         enddo
17561       enddo
17562       nl=0
17563        if(flag) then
17564         do il=seg1+nsep,seg2
17565           do jl=seg1,il-nsep
17566             nl=nl+1
17567             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17568                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17569                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17570             dij=dist(il,jl)
17571             sim = 1.0d0/sigm(d0ij)
17572             sim = sim*sim
17573             dd0 = dij-d0ij
17574             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17575           do k=1,3
17576               ddqij = (c(k,il)-c(k,jl))*fac
17577               dqwol(k,il)=dqwol(k,il)+ddqij
17578               dqwol(k,jl)=dqwol(k,jl)-ddqij
17579             enddo
17580
17581             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17582               nl=nl+1
17583               d0ijCM=dsqrt( &
17584                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17585                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17586                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17587               dijCM=dist(il+nres,jl+nres)
17588               sim = 1.0d0/sigm(d0ijCM)
17589               sim = sim*sim
17590               dd0=dijCM-d0ijCM
17591               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17592               do k=1,3
17593                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17594                 dxqwol(k,il)=dxqwol(k,il)+ddqij
17595                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17596               enddo
17597             endif
17598           enddo
17599         enddo
17600        else
17601         do il=seg1,seg2
17602         if((seg3-il).lt.3) then
17603              secseg=il+3
17604         else
17605              secseg=seg3
17606         endif
17607           do jl=secseg,seg4
17608             nl=nl+1
17609             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17610                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17611                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17612             dij=dist(il,jl)
17613             sim = 1.0d0/sigm(d0ij)
17614             sim = sim*sim
17615             dd0 = dij-d0ij
17616             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17617             do k=1,3
17618               ddqij = (c(k,il)-c(k,jl))*fac
17619               dqwol(k,il)=dqwol(k,il)+ddqij
17620               dqwol(k,jl)=dqwol(k,jl)-ddqij
17621             enddo
17622             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17623               nl=nl+1
17624               d0ijCM=dsqrt( &
17625                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17626                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17627                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17628               dijCM=dist(il+nres,jl+nres)
17629               sim = 1.0d0/sigm(d0ijCM)
17630               sim=sim*sim
17631               dd0 = dijCM-d0ijCM
17632               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17633               do k=1,3
17634                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17635                dxqwol(k,il)=dxqwol(k,il)+ddqij
17636                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17637               enddo
17638             endif
17639           enddo
17640         enddo
17641       endif
17642       enddo
17643        do i=0,nres
17644          do j=1,3
17645            dqwol(j,i)=dqwol(j,i)/nl
17646            dxqwol(j,i)=dxqwol(j,i)/nl
17647          enddo
17648        enddo
17649       return
17650       end subroutine qwolynes_prim
17651 !-----------------------------------------------------------------------------
17652       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17653 !      implicit real*8 (a-h,o-z)
17654 !      include 'DIMENSIONS'
17655 !      include 'COMMON.IOUNITS'
17656 !      include 'COMMON.CHAIN'
17657 !      include 'COMMON.INTERACT'
17658 !      include 'COMMON.VAR'
17659       integer :: seg1,seg2,seg3,seg4
17660       logical :: flag
17661       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17662       real(kind=8),dimension(3,0:2*nres) :: cdummy
17663       real(kind=8) :: q1,q2
17664       real(kind=8) :: delta=1.0d-10
17665       integer :: i,j
17666
17667       do i=0,nres
17668         do j=1,3
17669           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17670           cdummy(j,i)=c(j,i)
17671           c(j,i)=c(j,i)+delta
17672           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17673           qwolan(j,i)=(q2-q1)/delta
17674           c(j,i)=cdummy(j,i)
17675         enddo
17676       enddo
17677       do i=0,nres
17678         do j=1,3
17679           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17680           cdummy(j,i+nres)=c(j,i+nres)
17681           c(j,i+nres)=c(j,i+nres)+delta
17682           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17683           qwolxan(j,i)=(q2-q1)/delta
17684           c(j,i+nres)=cdummy(j,i+nres)
17685         enddo
17686       enddo
17687 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17688 !      do i=0,nct
17689 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17690 !      enddo
17691 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17692 !      do i=0,nct
17693 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17694 !      enddo
17695       return
17696       end subroutine qwol_num
17697 !-----------------------------------------------------------------------------
17698       subroutine EconstrQ
17699 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17700 !      implicit real*8 (a-h,o-z)
17701 !      include 'DIMENSIONS'
17702 !      include 'COMMON.CONTROL'
17703 !      include 'COMMON.VAR'
17704 !      include 'COMMON.MD'
17705       use MD_data
17706 !#ifndef LANG0
17707 !      include 'COMMON.LANGEVIN'
17708 !#else
17709 !      include 'COMMON.LANGEVIN.lang0'
17710 !#endif
17711 !      include 'COMMON.CHAIN'
17712 !      include 'COMMON.DERIV'
17713 !      include 'COMMON.GEO'
17714 !      include 'COMMON.LOCAL'
17715 !      include 'COMMON.INTERACT'
17716 !      include 'COMMON.IOUNITS'
17717 !      include 'COMMON.NAMES'
17718 !      include 'COMMON.TIME1'
17719       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
17720       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
17721                    duconst,duxconst
17722       integer :: kstart,kend,lstart,lend,idummy
17723       real(kind=8) :: delta=1.0d-7
17724       integer :: i,j,k,ii
17725       do i=0,nres
17726          do j=1,3
17727             duconst(j,i)=0.0d0
17728             dudconst(j,i)=0.0d0
17729             duxconst(j,i)=0.0d0
17730             dudxconst(j,i)=0.0d0
17731          enddo
17732       enddo
17733       Uconst=0.0d0
17734       do i=1,nfrag
17735          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17736            idummy,idummy)
17737          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
17738 ! Calculating the derivatives of Constraint energy with respect to Q
17739          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
17740            qinfrag(i,iset))
17741 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
17742 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
17743 !         hmnum=(hm2-hm1)/delta
17744 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
17745 !     &   qinfrag(i,iset))
17746 !         write(iout,*) "harmonicnum frag", hmnum
17747 ! Calculating the derivatives of Q with respect to cartesian coordinates
17748          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17749           idummy,idummy)
17750 !         write(iout,*) "dqwol "
17751 !         do ii=1,nres
17752 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17753 !         enddo
17754 !         write(iout,*) "dxqwol "
17755 !         do ii=1,nres
17756 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17757 !         enddo
17758 ! Calculating numerical gradients of dU/dQi and dQi/dxi
17759 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
17760 !     &  ,idummy,idummy)
17761 !  The gradients of Uconst in Cs
17762          do ii=0,nres
17763             do j=1,3
17764                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
17765                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
17766             enddo
17767          enddo
17768       enddo
17769       do i=1,npair
17770          kstart=ifrag(1,ipair(1,i,iset),iset)
17771          kend=ifrag(2,ipair(1,i,iset),iset)
17772          lstart=ifrag(1,ipair(2,i,iset),iset)
17773          lend=ifrag(2,ipair(2,i,iset),iset)
17774          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
17775          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
17776 !  Calculating dU/dQ
17777          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
17778 !         hm1=harmonic(qpair(i),qinpair(i,iset))
17779 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
17780 !         hmnum=(hm2-hm1)/delta
17781 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
17782 !     &   qinpair(i,iset))
17783 !         write(iout,*) "harmonicnum pair ", hmnum
17784 ! Calculating dQ/dXi
17785          call qwolynes_prim(kstart,kend,.false.,&
17786           lstart,lend)
17787 !         write(iout,*) "dqwol "
17788 !         do ii=1,nres
17789 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17790 !         enddo
17791 !         write(iout,*) "dxqwol "
17792 !         do ii=1,nres
17793 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17794 !        enddo
17795 ! Calculating numerical gradients
17796 !        call qwol_num(kstart,kend,.false.
17797 !     &  ,lstart,lend)
17798 ! The gradients of Uconst in Cs
17799          do ii=0,nres
17800             do j=1,3
17801                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
17802                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
17803             enddo
17804          enddo
17805       enddo
17806 !      write(iout,*) "Uconst inside subroutine ", Uconst
17807 ! Transforming the gradients from Cs to dCs for the backbone
17808       do i=0,nres
17809          do j=i+1,nres
17810            do k=1,3
17811              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
17812            enddo
17813          enddo
17814       enddo
17815 !  Transforming the gradients from Cs to dCs for the side chains
17816       do i=1,nres
17817          do j=1,3
17818            dudxconst(j,i)=duxconst(j,i)
17819          enddo
17820       enddo
17821 !      write(iout,*) "dU/ddc backbone "
17822 !       do ii=0,nres
17823 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
17824 !      enddo
17825 !      write(iout,*) "dU/ddX side chain "
17826 !      do ii=1,nres
17827 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
17828 !      enddo
17829 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
17830 !      call dEconstrQ_num
17831       return
17832       end subroutine EconstrQ
17833 !-----------------------------------------------------------------------------
17834       subroutine dEconstrQ_num
17835 ! Calculating numerical dUconst/ddc and dUconst/ddx
17836 !      implicit real*8 (a-h,o-z)
17837 !      include 'DIMENSIONS'
17838 !      include 'COMMON.CONTROL'
17839 !      include 'COMMON.VAR'
17840 !      include 'COMMON.MD'
17841       use MD_data
17842 !#ifndef LANG0
17843 !      include 'COMMON.LANGEVIN'
17844 !#else
17845 !      include 'COMMON.LANGEVIN.lang0'
17846 !#endif
17847 !      include 'COMMON.CHAIN'
17848 !      include 'COMMON.DERIV'
17849 !      include 'COMMON.GEO'
17850 !      include 'COMMON.LOCAL'
17851 !      include 'COMMON.INTERACT'
17852 !      include 'COMMON.IOUNITS'
17853 !      include 'COMMON.NAMES'
17854 !      include 'COMMON.TIME1'
17855       real(kind=8) :: uzap1,uzap2
17856       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17857       integer :: kstart,kend,lstart,lend,idummy
17858       real(kind=8) :: delta=1.0d-7
17859 !el local variables
17860       integer :: i,ii,j
17861 !     real(kind=8) ::
17862 !     For the backbone
17863       do i=0,nres-1
17864          do j=1,3
17865             dUcartan(j,i)=0.0d0
17866             cdummy(j,i)=dc(j,i)
17867             dc(j,i)=dc(j,i)+delta
17868             call chainbuild_cart
17869           uzap2=0.0d0
17870             do ii=1,nfrag
17871              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17872                 idummy,idummy)
17873                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17874                 qinfrag(ii,iset))
17875             enddo
17876             do ii=1,npair
17877                kstart=ifrag(1,ipair(1,ii,iset),iset)
17878                kend=ifrag(2,ipair(1,ii,iset),iset)
17879                lstart=ifrag(1,ipair(2,ii,iset),iset)
17880                lend=ifrag(2,ipair(2,ii,iset),iset)
17881                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17882                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17883                  qinpair(ii,iset))
17884             enddo
17885             dc(j,i)=cdummy(j,i)
17886             call chainbuild_cart
17887             uzap1=0.0d0
17888              do ii=1,nfrag
17889              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17890                 idummy,idummy)
17891                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17892                 qinfrag(ii,iset))
17893             enddo
17894             do ii=1,npair
17895                kstart=ifrag(1,ipair(1,ii,iset),iset)
17896                kend=ifrag(2,ipair(1,ii,iset),iset)
17897                lstart=ifrag(1,ipair(2,ii,iset),iset)
17898                lend=ifrag(2,ipair(2,ii,iset),iset)
17899                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17900                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17901                 qinpair(ii,iset))
17902             enddo
17903             ducartan(j,i)=(uzap2-uzap1)/(delta)
17904          enddo
17905       enddo
17906 ! Calculating numerical gradients for dU/ddx
17907       do i=0,nres-1
17908          duxcartan(j,i)=0.0d0
17909          do j=1,3
17910             cdummy(j,i)=dc(j,i+nres)
17911             dc(j,i+nres)=dc(j,i+nres)+delta
17912             call chainbuild_cart
17913           uzap2=0.0d0
17914             do ii=1,nfrag
17915              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17916                 idummy,idummy)
17917                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17918                 qinfrag(ii,iset))
17919             enddo
17920             do ii=1,npair
17921                kstart=ifrag(1,ipair(1,ii,iset),iset)
17922                kend=ifrag(2,ipair(1,ii,iset),iset)
17923                lstart=ifrag(1,ipair(2,ii,iset),iset)
17924                lend=ifrag(2,ipair(2,ii,iset),iset)
17925                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17926                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17927                 qinpair(ii,iset))
17928             enddo
17929             dc(j,i+nres)=cdummy(j,i)
17930             call chainbuild_cart
17931             uzap1=0.0d0
17932              do ii=1,nfrag
17933                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17934                 ifrag(2,ii,iset),.true.,idummy,idummy)
17935                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17936                 qinfrag(ii,iset))
17937             enddo
17938             do ii=1,npair
17939                kstart=ifrag(1,ipair(1,ii,iset),iset)
17940                kend=ifrag(2,ipair(1,ii,iset),iset)
17941                lstart=ifrag(1,ipair(2,ii,iset),iset)
17942                lend=ifrag(2,ipair(2,ii,iset),iset)
17943                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17944                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17945                 qinpair(ii,iset))
17946             enddo
17947             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17948          enddo
17949       enddo
17950       write(iout,*) "Numerical dUconst/ddc backbone "
17951       do ii=0,nres
17952         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17953       enddo
17954 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17955 !      do ii=1,nres
17956 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17957 !      enddo
17958       return
17959       end subroutine dEconstrQ_num
17960 !-----------------------------------------------------------------------------
17961 ! ssMD.F
17962 !-----------------------------------------------------------------------------
17963       subroutine check_energies
17964
17965 !      use random, only: ran_number
17966
17967 !      implicit none
17968 !     Includes
17969 !      include 'DIMENSIONS'
17970 !      include 'COMMON.CHAIN'
17971 !      include 'COMMON.VAR'
17972 !      include 'COMMON.IOUNITS'
17973 !      include 'COMMON.SBRIDGE'
17974 !      include 'COMMON.LOCAL'
17975 !      include 'COMMON.GEO'
17976
17977 !     External functions
17978 !EL      double precision ran_number
17979 !EL      external ran_number
17980
17981 !     Local variables
17982       integer :: i,j,k,l,lmax,p,pmax
17983       real(kind=8) :: rmin,rmax
17984       real(kind=8) :: eij
17985
17986       real(kind=8) :: d
17987       real(kind=8) :: wi,rij,tj,pj
17988 !      return
17989
17990       i=5
17991       j=14
17992
17993       d=dsc(1)
17994       rmin=2.0D0
17995       rmax=12.0D0
17996
17997       lmax=10000
17998       pmax=1
17999
18000       do k=1,3
18001         c(k,i)=0.0D0
18002         c(k,j)=0.0D0
18003         c(k,nres+i)=0.0D0
18004         c(k,nres+j)=0.0D0
18005       enddo
18006
18007       do l=1,lmax
18008
18009 !t        wi=ran_number(0.0D0,pi)
18010 !        wi=ran_number(0.0D0,pi/6.0D0)
18011 !        wi=0.0D0
18012 !t        tj=ran_number(0.0D0,pi)
18013 !t        pj=ran_number(0.0D0,pi)
18014 !        pj=ran_number(0.0D0,pi/6.0D0)
18015 !        pj=0.0D0
18016
18017         do p=1,pmax
18018 !t           rij=ran_number(rmin,rmax)
18019
18020            c(1,j)=d*sin(pj)*cos(tj)
18021            c(2,j)=d*sin(pj)*sin(tj)
18022            c(3,j)=d*cos(pj)
18023
18024            c(3,nres+i)=-rij
18025
18026            c(1,i)=d*sin(wi)
18027            c(3,i)=-rij-d*cos(wi)
18028
18029            do k=1,3
18030               dc(k,nres+i)=c(k,nres+i)-c(k,i)
18031               dc_norm(k,nres+i)=dc(k,nres+i)/d
18032               dc(k,nres+j)=c(k,nres+j)-c(k,j)
18033               dc_norm(k,nres+j)=dc(k,nres+j)/d
18034            enddo
18035
18036            call dyn_ssbond_ene(i,j,eij)
18037         enddo
18038       enddo
18039       call exit(1)
18040       return
18041       end subroutine check_energies
18042 !-----------------------------------------------------------------------------
18043       subroutine dyn_ssbond_ene(resi,resj,eij)
18044 !      implicit none
18045 !      Includes
18046       use calc_data
18047       use comm_sschecks
18048 !      include 'DIMENSIONS'
18049 !      include 'COMMON.SBRIDGE'
18050 !      include 'COMMON.CHAIN'
18051 !      include 'COMMON.DERIV'
18052 !      include 'COMMON.LOCAL'
18053 !      include 'COMMON.INTERACT'
18054 !      include 'COMMON.VAR'
18055 !      include 'COMMON.IOUNITS'
18056 !      include 'COMMON.CALC'
18057 #ifndef CLUST
18058 #ifndef WHAM
18059        use MD_data
18060 !      include 'COMMON.MD'
18061 !      use MD, only: totT,t_bath
18062 #endif
18063 #endif
18064 !     External functions
18065 !EL      double precision h_base
18066 !EL      external h_base
18067
18068 !     Input arguments
18069       integer :: resi,resj
18070
18071 !     Output arguments
18072       real(kind=8) :: eij
18073
18074 !     Local variables
18075       logical :: havebond
18076       integer itypi,itypj
18077       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
18078       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
18079       real(kind=8),dimension(3) :: dcosom1,dcosom2
18080       real(kind=8) :: ed
18081       real(kind=8) :: pom1,pom2
18082       real(kind=8) :: ljA,ljB,ljXs
18083       real(kind=8),dimension(1:3) :: d_ljB
18084       real(kind=8) :: ssA,ssB,ssC,ssXs
18085       real(kind=8) :: ssxm,ljxm,ssm,ljm
18086       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
18087       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
18088       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
18089 !-------FIRST METHOD
18090       real(kind=8) :: xm
18091       real(kind=8),dimension(1:3) :: d_xm
18092 !-------END FIRST METHOD
18093 !-------SECOND METHOD
18094 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
18095 !-------END SECOND METHOD
18096
18097 !-------TESTING CODE
18098 !el      logical :: checkstop,transgrad
18099 !el      common /sschecks/ checkstop,transgrad
18100
18101       integer :: icheck,nicheck,jcheck,njcheck
18102       real(kind=8),dimension(-1:1) :: echeck
18103       real(kind=8) :: deps,ssx0,ljx0
18104 !-------END TESTING CODE
18105
18106       eij=0.0d0
18107       i=resi
18108       j=resj
18109
18110 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
18111 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
18112
18113       itypi=itype(i,1)
18114       dxi=dc_norm(1,nres+i)
18115       dyi=dc_norm(2,nres+i)
18116       dzi=dc_norm(3,nres+i)
18117       dsci_inv=vbld_inv(i+nres)
18118
18119       itypj=itype(j,1)
18120       xj=c(1,nres+j)-c(1,nres+i)
18121       yj=c(2,nres+j)-c(2,nres+i)
18122       zj=c(3,nres+j)-c(3,nres+i)
18123       dxj=dc_norm(1,nres+j)
18124       dyj=dc_norm(2,nres+j)
18125       dzj=dc_norm(3,nres+j)
18126       dscj_inv=vbld_inv(j+nres)
18127
18128       chi1=chi(itypi,itypj)
18129       chi2=chi(itypj,itypi)
18130       chi12=chi1*chi2
18131       chip1=chip(itypi)
18132       chip2=chip(itypj)
18133       chip12=chip1*chip2
18134       alf1=alp(itypi)
18135       alf2=alp(itypj)
18136       alf12=0.5D0*(alf1+alf2)
18137
18138       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
18139       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18140 !     The following are set in sc_angular
18141 !      erij(1)=xj*rij
18142 !      erij(2)=yj*rij
18143 !      erij(3)=zj*rij
18144 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
18145 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
18146 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
18147       call sc_angular
18148       rij=1.0D0/rij  ! Reset this so it makes sense
18149
18150       sig0ij=sigma(itypi,itypj)
18151       sig=sig0ij*dsqrt(1.0D0/sigsq)
18152
18153       ljXs=sig-sig0ij
18154       ljA=eps1*eps2rt**2*eps3rt**2
18155       ljB=ljA*bb_aq(itypi,itypj)
18156       ljA=ljA*aa_aq(itypi,itypj)
18157       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
18158
18159       ssXs=d0cm
18160       deltat1=1.0d0-om1
18161       deltat2=1.0d0+om2
18162       deltat12=om2-om1+2.0d0
18163       cosphi=om12-om1*om2
18164       ssA=akcm
18165       ssB=akct*deltat12
18166       ssC=ss_depth &
18167            +akth*(deltat1*deltat1+deltat2*deltat2) &
18168            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
18169       ssxm=ssXs-0.5D0*ssB/ssA
18170
18171 !-------TESTING CODE
18172 !$$$c     Some extra output
18173 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
18174 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
18175 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
18176 !$$$      if (ssx0.gt.0.0d0) then
18177 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
18178 !$$$      else
18179 !$$$        ssx0=ssxm
18180 !$$$      endif
18181 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
18182 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
18183 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
18184 !$$$      return
18185 !-------END TESTING CODE
18186
18187 !-------TESTING CODE
18188 !     Stop and plot energy and derivative as a function of distance
18189       if (checkstop) then
18190         ssm=ssC-0.25D0*ssB*ssB/ssA
18191         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18192         if (ssm.lt.ljm .and. &
18193              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
18194           nicheck=1000
18195           njcheck=1
18196           deps=0.5d-7
18197         else
18198           checkstop=.false.
18199         endif
18200       endif
18201       if (.not.checkstop) then
18202         nicheck=0
18203         njcheck=-1
18204       endif
18205
18206       do icheck=0,nicheck
18207       do jcheck=-1,njcheck
18208       if (checkstop) rij=(ssxm-1.0d0)+ &
18209              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
18210 !-------END TESTING CODE
18211
18212       if (rij.gt.ljxm) then
18213         havebond=.false.
18214         ljd=rij-ljXs
18215         fac=(1.0D0/ljd)**expon
18216         e1=fac*fac*aa_aq(itypi,itypj)
18217         e2=fac*bb_aq(itypi,itypj)
18218         eij=eps1*eps2rt*eps3rt*(e1+e2)
18219         eps2der=eij*eps3rt
18220         eps3der=eij*eps2rt
18221         eij=eij*eps2rt*eps3rt
18222
18223         sigder=-sig/sigsq
18224         e1=e1*eps1*eps2rt**2*eps3rt**2
18225         ed=-expon*(e1+eij)/ljd
18226         sigder=ed*sigder
18227         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18228         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18229         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18230              -2.0D0*alf12*eps3der+sigder*sigsq_om12
18231       else if (rij.lt.ssxm) then
18232         havebond=.true.
18233         ssd=rij-ssXs
18234         eij=ssA*ssd*ssd+ssB*ssd+ssC
18235
18236         ed=2*akcm*ssd+akct*deltat12
18237         pom1=akct*ssd
18238         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18239         eom1=-2*akth*deltat1-pom1-om2*pom2
18240         eom2= 2*akth*deltat2+pom1-om1*pom2
18241         eom12=pom2
18242       else
18243         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18244
18245         d_ssxm(1)=0.5D0*akct/ssA
18246         d_ssxm(2)=-d_ssxm(1)
18247         d_ssxm(3)=0.0D0
18248
18249         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18250         d_ljxm(2)=d_ljxm(1)*sigsq_om2
18251         d_ljxm(3)=d_ljxm(1)*sigsq_om12
18252         d_ljxm(1)=d_ljxm(1)*sigsq_om1
18253
18254 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18255         xm=0.5d0*(ssxm+ljxm)
18256         do k=1,3
18257           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18258         enddo
18259         if (rij.lt.xm) then
18260           havebond=.true.
18261           ssm=ssC-0.25D0*ssB*ssB/ssA
18262           d_ssm(1)=0.5D0*akct*ssB/ssA
18263           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18264           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18265           d_ssm(3)=omega
18266           f1=(rij-xm)/(ssxm-xm)
18267           f2=(rij-ssxm)/(xm-ssxm)
18268           h1=h_base(f1,hd1)
18269           h2=h_base(f2,hd2)
18270           eij=ssm*h1+Ht*h2
18271           delta_inv=1.0d0/(xm-ssxm)
18272           deltasq_inv=delta_inv*delta_inv
18273           fac=ssm*hd1-Ht*hd2
18274           fac1=deltasq_inv*fac*(xm-rij)
18275           fac2=deltasq_inv*fac*(rij-ssxm)
18276           ed=delta_inv*(Ht*hd2-ssm*hd1)
18277           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18278           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18279           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18280         else
18281           havebond=.false.
18282           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18283           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18284           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18285           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18286                alf12/eps3rt)
18287           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18288           f1=(rij-ljxm)/(xm-ljxm)
18289           f2=(rij-xm)/(ljxm-xm)
18290           h1=h_base(f1,hd1)
18291           h2=h_base(f2,hd2)
18292           eij=Ht*h1+ljm*h2
18293           delta_inv=1.0d0/(ljxm-xm)
18294           deltasq_inv=delta_inv*delta_inv
18295           fac=Ht*hd1-ljm*hd2
18296           fac1=deltasq_inv*fac*(ljxm-rij)
18297           fac2=deltasq_inv*fac*(rij-xm)
18298           ed=delta_inv*(ljm*hd2-Ht*hd1)
18299           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18300           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18301           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18302         endif
18303 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18304
18305 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18306 !$$$        ssd=rij-ssXs
18307 !$$$        ljd=rij-ljXs
18308 !$$$        fac1=rij-ljxm
18309 !$$$        fac2=rij-ssxm
18310 !$$$
18311 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18312 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18313 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18314 !$$$
18315 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18316 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18317 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18318 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18319 !$$$        d_ssm(3)=omega
18320 !$$$
18321 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18322 !$$$        do k=1,3
18323 !$$$          d_ljm(k)=ljm*d_ljB(k)
18324 !$$$        enddo
18325 !$$$        ljm=ljm*ljB
18326 !$$$
18327 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18328 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18329 !$$$        d_ss(2)=akct*ssd
18330 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18331 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18332 !$$$        d_ss(3)=omega
18333 !$$$
18334 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18335 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18336 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18337 !$$$        do k=1,3
18338 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18339 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18340 !$$$        enddo
18341 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18342 !$$$
18343 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18344 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18345 !$$$        h1=h_base(f1,hd1)
18346 !$$$        h2=h_base(f2,hd2)
18347 !$$$        eij=ss*h1+ljf*h2
18348 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18349 !$$$        deltasq_inv=delta_inv*delta_inv
18350 !$$$        fac=ljf*hd2-ss*hd1
18351 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18352 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18353 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18354 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18355 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18356 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18357 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18358 !$$$
18359 !$$$        havebond=.false.
18360 !$$$        if (ed.gt.0.0d0) havebond=.true.
18361 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18362
18363       endif
18364
18365       if (havebond) then
18366 !#ifndef CLUST
18367 !#ifndef WHAM
18368 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18369 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18370 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18371 !        endif
18372 !#endif
18373 !#endif
18374         dyn_ssbond_ij(i,j)=eij
18375       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18376         dyn_ssbond_ij(i,j)=1.0d300
18377 !#ifndef CLUST
18378 !#ifndef WHAM
18379 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18380 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18381 !#endif
18382 !#endif
18383       endif
18384
18385 !-------TESTING CODE
18386 !el      if (checkstop) then
18387         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18388              "CHECKSTOP",rij,eij,ed
18389         echeck(jcheck)=eij
18390 !el      endif
18391       enddo
18392       if (checkstop) then
18393         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18394       endif
18395       enddo
18396       if (checkstop) then
18397         transgrad=.true.
18398         checkstop=.false.
18399       endif
18400 !-------END TESTING CODE
18401
18402       do k=1,3
18403         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18404         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18405       enddo
18406       do k=1,3
18407         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18408       enddo
18409       do k=1,3
18410         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18411              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18412              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18413         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18414              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18415              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18416       enddo
18417 !grad      do k=i,j-1
18418 !grad        do l=1,3
18419 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18420 !grad        enddo
18421 !grad      enddo
18422
18423       do l=1,3
18424         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18425         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18426       enddo
18427
18428       return
18429       end subroutine dyn_ssbond_ene
18430 !--------------------------------------------------------------------------
18431          subroutine triple_ssbond_ene(resi,resj,resk,eij)
18432 !      implicit none
18433 !      Includes
18434       use calc_data
18435       use comm_sschecks
18436 !      include 'DIMENSIONS'
18437 !      include 'COMMON.SBRIDGE'
18438 !      include 'COMMON.CHAIN'
18439 !      include 'COMMON.DERIV'
18440 !      include 'COMMON.LOCAL'
18441 !      include 'COMMON.INTERACT'
18442 !      include 'COMMON.VAR'
18443 !      include 'COMMON.IOUNITS'
18444 !      include 'COMMON.CALC'
18445 #ifndef CLUST
18446 #ifndef WHAM
18447        use MD_data
18448 !      include 'COMMON.MD'
18449 !      use MD, only: totT,t_bath
18450 #endif
18451 #endif
18452       double precision h_base
18453       external h_base
18454
18455 !c     Input arguments
18456       integer resi,resj,resk,m,itypi,itypj,itypk
18457
18458 !c     Output arguments
18459       double precision eij,eij1,eij2,eij3
18460
18461 !c     Local variables
18462       logical havebond
18463 !c      integer itypi,itypj,k,l
18464       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
18465       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
18466       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
18467       double precision sig0ij,ljd,sig,fac,e1,e2
18468       double precision dcosom1(3),dcosom2(3),ed
18469       double precision pom1,pom2
18470       double precision ljA,ljB,ljXs
18471       double precision d_ljB(1:3)
18472       double precision ssA,ssB,ssC,ssXs
18473       double precision ssxm,ljxm,ssm,ljm
18474       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
18475       eij=0.0
18476       if (dtriss.eq.0) return
18477       i=resi
18478       j=resj
18479       k=resk
18480 !C      write(iout,*) resi,resj,resk
18481       itypi=itype(i,1)
18482       dxi=dc_norm(1,nres+i)
18483       dyi=dc_norm(2,nres+i)
18484       dzi=dc_norm(3,nres+i)
18485       dsci_inv=vbld_inv(i+nres)
18486       xi=c(1,nres+i)
18487       yi=c(2,nres+i)
18488       zi=c(3,nres+i)
18489       itypj=itype(j,1)
18490       xj=c(1,nres+j)
18491       yj=c(2,nres+j)
18492       zj=c(3,nres+j)
18493
18494       dxj=dc_norm(1,nres+j)
18495       dyj=dc_norm(2,nres+j)
18496       dzj=dc_norm(3,nres+j)
18497       dscj_inv=vbld_inv(j+nres)
18498       itypk=itype(k,1)
18499       xk=c(1,nres+k)
18500       yk=c(2,nres+k)
18501       zk=c(3,nres+k)
18502
18503       dxk=dc_norm(1,nres+k)
18504       dyk=dc_norm(2,nres+k)
18505       dzk=dc_norm(3,nres+k)
18506       dscj_inv=vbld_inv(k+nres)
18507       xij=xj-xi
18508       xik=xk-xi
18509       xjk=xk-xj
18510       yij=yj-yi
18511       yik=yk-yi
18512       yjk=yk-yj
18513       zij=zj-zi
18514       zik=zk-zi
18515       zjk=zk-zj
18516       rrij=(xij*xij+yij*yij+zij*zij)
18517       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18518       rrik=(xik*xik+yik*yik+zik*zik)
18519       rik=dsqrt(rrik)
18520       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18521       rjk=dsqrt(rrjk)
18522 !C there are three combination of distances for each trisulfide bonds
18523 !C The first case the ith atom is the center
18524 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18525 !C distance y is second distance the a,b,c,d are parameters derived for
18526 !C this problem d parameter was set as a penalty currenlty set to 1.
18527       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18528       eij1=0.0d0
18529       else
18530       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18531       endif
18532 !C second case jth atom is center
18533       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18534       eij2=0.0d0
18535       else
18536       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18537       endif
18538 !C the third case kth atom is the center
18539       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18540       eij3=0.0d0
18541       else
18542       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18543       endif
18544 !C      eij2=0.0
18545 !C      eij3=0.0
18546 !C      eij1=0.0
18547       eij=eij1+eij2+eij3
18548 !C      write(iout,*)i,j,k,eij
18549 !C The energy penalty calculated now time for the gradient part
18550 !C derivative over rij
18551       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18552       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18553             gg(1)=xij*fac/rij
18554             gg(2)=yij*fac/rij
18555             gg(3)=zij*fac/rij
18556       do m=1,3
18557         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18558         gvdwx(m,j)=gvdwx(m,j)+gg(m)
18559       enddo
18560
18561       do l=1,3
18562         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18563         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18564       enddo
18565 !C now derivative over rik
18566       fac=-eij1**2/dtriss* &
18567       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18568       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18569             gg(1)=xik*fac/rik
18570             gg(2)=yik*fac/rik
18571             gg(3)=zik*fac/rik
18572       do m=1,3
18573         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18574         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18575       enddo
18576       do l=1,3
18577         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18578         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18579       enddo
18580 !C now derivative over rjk
18581       fac=-eij2**2/dtriss* &
18582       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18583       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18584             gg(1)=xjk*fac/rjk
18585             gg(2)=yjk*fac/rjk
18586             gg(3)=zjk*fac/rjk
18587       do m=1,3
18588         gvdwx(m,j)=gvdwx(m,j)-gg(m)
18589         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18590       enddo
18591       do l=1,3
18592         gvdwc(l,j)=gvdwc(l,j)-gg(l)
18593         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18594       enddo
18595       return
18596       end subroutine triple_ssbond_ene
18597
18598
18599
18600 !-----------------------------------------------------------------------------
18601       real(kind=8) function h_base(x,deriv)
18602 !     A smooth function going 0->1 in range [0,1]
18603 !     It should NOT be called outside range [0,1], it will not work there.
18604       implicit none
18605
18606 !     Input arguments
18607       real(kind=8) :: x
18608
18609 !     Output arguments
18610       real(kind=8) :: deriv
18611
18612 !     Local variables
18613       real(kind=8) :: xsq
18614
18615
18616 !     Two parabolas put together.  First derivative zero at extrema
18617 !$$$      if (x.lt.0.5D0) then
18618 !$$$        h_base=2.0D0*x*x
18619 !$$$        deriv=4.0D0*x
18620 !$$$      else
18621 !$$$        deriv=1.0D0-x
18622 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18623 !$$$        deriv=4.0D0*deriv
18624 !$$$      endif
18625
18626 !     Third degree polynomial.  First derivative zero at extrema
18627       h_base=x*x*(3.0d0-2.0d0*x)
18628       deriv=6.0d0*x*(1.0d0-x)
18629
18630 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18631 !$$$      xsq=x*x
18632 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18633 !$$$      deriv=x-1.0d0
18634 !$$$      deriv=deriv*deriv
18635 !$$$      deriv=30.0d0*xsq*deriv
18636
18637       return
18638       end function h_base
18639 !-----------------------------------------------------------------------------
18640       subroutine dyn_set_nss
18641 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18642 !      implicit none
18643       use MD_data, only: totT,t_bath
18644 !     Includes
18645 !      include 'DIMENSIONS'
18646 #ifdef MPI
18647       include "mpif.h"
18648 #endif
18649 !      include 'COMMON.SBRIDGE'
18650 !      include 'COMMON.CHAIN'
18651 !      include 'COMMON.IOUNITS'
18652 !      include 'COMMON.SETUP'
18653 !      include 'COMMON.MD'
18654 !     Local variables
18655       real(kind=8) :: emin
18656       integer :: i,j,imin,ierr
18657       integer :: diff,allnss,newnss
18658       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18659                 newihpb,newjhpb
18660       logical :: found
18661       integer,dimension(0:nfgtasks) :: i_newnss
18662       integer,dimension(0:nfgtasks) :: displ
18663       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18664       integer :: g_newnss
18665
18666       allnss=0
18667       do i=1,nres-1
18668         do j=i+1,nres
18669           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18670             allnss=allnss+1
18671             allflag(allnss)=0
18672             allihpb(allnss)=i
18673             alljhpb(allnss)=j
18674           endif
18675         enddo
18676       enddo
18677
18678 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18679
18680  1    emin=1.0d300
18681       do i=1,allnss
18682         if (allflag(i).eq.0 .and. &
18683              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18684           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18685           imin=i
18686         endif
18687       enddo
18688       if (emin.lt.1.0d300) then
18689         allflag(imin)=1
18690         do i=1,allnss
18691           if (allflag(i).eq.0 .and. &
18692                (allihpb(i).eq.allihpb(imin) .or. &
18693                alljhpb(i).eq.allihpb(imin) .or. &
18694                allihpb(i).eq.alljhpb(imin) .or. &
18695                alljhpb(i).eq.alljhpb(imin))) then
18696             allflag(i)=-1
18697           endif
18698         enddo
18699         goto 1
18700       endif
18701
18702 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18703
18704       newnss=0
18705       do i=1,allnss
18706         if (allflag(i).eq.1) then
18707           newnss=newnss+1
18708           newihpb(newnss)=allihpb(i)
18709           newjhpb(newnss)=alljhpb(i)
18710         endif
18711       enddo
18712
18713 #ifdef MPI
18714       if (nfgtasks.gt.1)then
18715
18716         call MPI_Reduce(newnss,g_newnss,1,&
18717           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
18718         call MPI_Gather(newnss,1,MPI_INTEGER,&
18719                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
18720         displ(0)=0
18721         do i=1,nfgtasks-1,1
18722           displ(i)=i_newnss(i-1)+displ(i-1)
18723         enddo
18724         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
18725                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
18726                          king,FG_COMM,IERR)
18727         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
18728                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
18729                          king,FG_COMM,IERR)
18730         if(fg_rank.eq.0) then
18731 !         print *,'g_newnss',g_newnss
18732 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
18733 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
18734          newnss=g_newnss
18735          do i=1,newnss
18736           newihpb(i)=g_newihpb(i)
18737           newjhpb(i)=g_newjhpb(i)
18738          enddo
18739         endif
18740       endif
18741 #endif
18742
18743       diff=newnss-nss
18744
18745 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
18746 !       print *,newnss,nss,maxdim
18747       do i=1,nss
18748         found=.false.
18749 !        print *,newnss
18750         do j=1,newnss
18751 !!          print *,j
18752           if (idssb(i).eq.newihpb(j) .and. &
18753                jdssb(i).eq.newjhpb(j)) found=.true.
18754         enddo
18755 #ifndef CLUST
18756 #ifndef WHAM
18757 !        write(iout,*) "found",found,i,j
18758         if (.not.found.and.fg_rank.eq.0) &
18759             write(iout,'(a15,f12.2,f8.1,2i5)') &
18760              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
18761 #endif
18762 #endif
18763       enddo
18764
18765       do i=1,newnss
18766         found=.false.
18767         do j=1,nss
18768 !          print *,i,j
18769           if (newihpb(i).eq.idssb(j) .and. &
18770                newjhpb(i).eq.jdssb(j)) found=.true.
18771         enddo
18772 #ifndef CLUST
18773 #ifndef WHAM
18774 !        write(iout,*) "found",found,i,j
18775         if (.not.found.and.fg_rank.eq.0) &
18776             write(iout,'(a15,f12.2,f8.1,2i5)') &
18777              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
18778 #endif
18779 #endif
18780       enddo
18781
18782       nss=newnss
18783       do i=1,nss
18784         idssb(i)=newihpb(i)
18785         jdssb(i)=newjhpb(i)
18786       enddo
18787
18788       return
18789       end subroutine dyn_set_nss
18790 ! Lipid transfer energy function
18791       subroutine Eliptransfer(eliptran)
18792 !C this is done by Adasko
18793 !C      print *,"wchodze"
18794 !C structure of box:
18795 !C      water
18796 !C--bordliptop-- buffore starts
18797 !C--bufliptop--- here true lipid starts
18798 !C      lipid
18799 !C--buflipbot--- lipid ends buffore starts
18800 !C--bordlipbot--buffore ends
18801       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
18802       integer :: i
18803       eliptran=0.0
18804 !      print *, "I am in eliptran"
18805       do i=ilip_start,ilip_end
18806 !C       do i=1,1
18807         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
18808          cycle
18809
18810         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
18811         if (positi.le.0.0) positi=positi+boxzsize
18812 !C        print *,i
18813 !C first for peptide groups
18814 !c for each residue check if it is in lipid or lipid water border area
18815        if ((positi.gt.bordlipbot)  &
18816       .and.(positi.lt.bordliptop)) then
18817 !C the energy transfer exist
18818         if (positi.lt.buflipbot) then
18819 !C what fraction I am in
18820          fracinbuf=1.0d0-      &
18821              ((positi-bordlipbot)/lipbufthick)
18822 !C lipbufthick is thickenes of lipid buffore
18823          sslip=sscalelip(fracinbuf)
18824          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18825          eliptran=eliptran+sslip*pepliptran
18826          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18827          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18828 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18829
18830 !C        print *,"doing sccale for lower part"
18831 !C         print *,i,sslip,fracinbuf,ssgradlip
18832         elseif (positi.gt.bufliptop) then
18833          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
18834          sslip=sscalelip(fracinbuf)
18835          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18836          eliptran=eliptran+sslip*pepliptran
18837          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18838          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18839 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18840 !C          print *, "doing sscalefor top part"
18841 !C         print *,i,sslip,fracinbuf,ssgradlip
18842         else
18843          eliptran=eliptran+pepliptran
18844 !C         print *,"I am in true lipid"
18845         endif
18846 !C       else
18847 !C       eliptran=elpitran+0.0 ! I am in water
18848        endif
18849        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
18850        enddo
18851 ! here starts the side chain transfer
18852        do i=ilip_start,ilip_end
18853         if (itype(i,1).eq.ntyp1) cycle
18854         positi=(mod(c(3,i+nres),boxzsize))
18855         if (positi.le.0) positi=positi+boxzsize
18856 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18857 !c for each residue check if it is in lipid or lipid water border area
18858 !C       respos=mod(c(3,i+nres),boxzsize)
18859 !C       print *,positi,bordlipbot,buflipbot
18860        if ((positi.gt.bordlipbot) &
18861        .and.(positi.lt.bordliptop)) then
18862 !C the energy transfer exist
18863         if (positi.lt.buflipbot) then
18864          fracinbuf=1.0d0-   &
18865            ((positi-bordlipbot)/lipbufthick)
18866 !C lipbufthick is thickenes of lipid buffore
18867          sslip=sscalelip(fracinbuf)
18868          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18869          eliptran=eliptran+sslip*liptranene(itype(i,1))
18870          gliptranx(3,i)=gliptranx(3,i) &
18871       +ssgradlip*liptranene(itype(i,1))
18872          gliptranc(3,i-1)= gliptranc(3,i-1) &
18873       +ssgradlip*liptranene(itype(i,1))
18874 !C         print *,"doing sccale for lower part"
18875         elseif (positi.gt.bufliptop) then
18876          fracinbuf=1.0d0-  &
18877       ((bordliptop-positi)/lipbufthick)
18878          sslip=sscalelip(fracinbuf)
18879          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18880          eliptran=eliptran+sslip*liptranene(itype(i,1))
18881          gliptranx(3,i)=gliptranx(3,i)  &
18882        +ssgradlip*liptranene(itype(i,1))
18883          gliptranc(3,i-1)= gliptranc(3,i-1) &
18884       +ssgradlip*liptranene(itype(i,1))
18885 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18886         else
18887          eliptran=eliptran+liptranene(itype(i,1))
18888 !C         print *,"I am in true lipid"
18889         endif
18890         endif ! if in lipid or buffor
18891 !C       else
18892 !C       eliptran=elpitran+0.0 ! I am in water
18893         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
18894        enddo
18895        return
18896        end  subroutine Eliptransfer
18897 !----------------------------------NANO FUNCTIONS
18898 !C-----------------------------------------------------------------------
18899 !C-----------------------------------------------------------
18900 !C This subroutine is to mimic the histone like structure but as well can be
18901 !C utilizet to nanostructures (infinit) small modification has to be used to
18902 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18903 !C gradient has to be modified at the ends
18904 !C The energy function is Kihara potential
18905 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18906 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18907 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18908 !C simple Kihara potential
18909       subroutine calctube(Etube)
18910       real(kind=8),dimension(3) :: vectube
18911       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18912        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
18913        sc_aa_tube,sc_bb_tube
18914       integer :: i,j,iti
18915       Etube=0.0d0
18916       do i=itube_start,itube_end
18917         enetube(i)=0.0d0
18918         enetube(i+nres)=0.0d0
18919       enddo
18920 !C first we calculate the distance from tube center
18921 !C for UNRES
18922        do i=itube_start,itube_end
18923 !C lets ommit dummy atoms for now
18924        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18925 !C now calculate distance from center of tube and direction vectors
18926       xmin=boxxsize
18927       ymin=boxysize
18928 ! Find minimum distance in periodic box
18929         do j=-1,1
18930          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18931          vectube(1)=vectube(1)+boxxsize*j
18932          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18933          vectube(2)=vectube(2)+boxysize*j
18934          xminact=abs(vectube(1)-tubecenter(1))
18935          yminact=abs(vectube(2)-tubecenter(2))
18936            if (xmin.gt.xminact) then
18937             xmin=xminact
18938             xtemp=vectube(1)
18939            endif
18940            if (ymin.gt.yminact) then
18941              ymin=yminact
18942              ytemp=vectube(2)
18943             endif
18944          enddo
18945       vectube(1)=xtemp
18946       vectube(2)=ytemp
18947       vectube(1)=vectube(1)-tubecenter(1)
18948       vectube(2)=vectube(2)-tubecenter(2)
18949
18950 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18951 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18952
18953 !C as the tube is infinity we do not calculate the Z-vector use of Z
18954 !C as chosen axis
18955       vectube(3)=0.0d0
18956 !C now calculte the distance
18957        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18958 !C now normalize vector
18959       vectube(1)=vectube(1)/tub_r
18960       vectube(2)=vectube(2)/tub_r
18961 !C calculte rdiffrence between r and r0
18962       rdiff=tub_r-tubeR0
18963 !C and its 6 power
18964       rdiff6=rdiff**6.0d0
18965 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18966        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18967 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18968 !C       print *,rdiff,rdiff6,pep_aa_tube
18969 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18970 !C now we calculate gradient
18971        fac=(-12.0d0*pep_aa_tube/rdiff6- &
18972             6.0d0*pep_bb_tube)/rdiff6/rdiff
18973 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18974 !C     &rdiff,fac
18975 !C now direction of gg_tube vector
18976         do j=1,3
18977         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18978         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18979         enddo
18980         enddo
18981 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18982 !C        print *,gg_tube(1,0),"TU"
18983
18984
18985        do i=itube_start,itube_end
18986 !C Lets not jump over memory as we use many times iti
18987          iti=itype(i,1)
18988 !C lets ommit dummy atoms for now
18989          if ((iti.eq.ntyp1)  &
18990 !C in UNRES uncomment the line below as GLY has no side-chain...
18991 !C      .or.(iti.eq.10)
18992         ) cycle
18993       xmin=boxxsize
18994       ymin=boxysize
18995         do j=-1,1
18996          vectube(1)=mod((c(1,i+nres)),boxxsize)
18997          vectube(1)=vectube(1)+boxxsize*j
18998          vectube(2)=mod((c(2,i+nres)),boxysize)
18999          vectube(2)=vectube(2)+boxysize*j
19000
19001          xminact=abs(vectube(1)-tubecenter(1))
19002          yminact=abs(vectube(2)-tubecenter(2))
19003            if (xmin.gt.xminact) then
19004             xmin=xminact
19005             xtemp=vectube(1)
19006            endif
19007            if (ymin.gt.yminact) then
19008              ymin=yminact
19009              ytemp=vectube(2)
19010             endif
19011          enddo
19012       vectube(1)=xtemp
19013       vectube(2)=ytemp
19014 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19015 !C     &     tubecenter(2)
19016       vectube(1)=vectube(1)-tubecenter(1)
19017       vectube(2)=vectube(2)-tubecenter(2)
19018
19019 !C as the tube is infinity we do not calculate the Z-vector use of Z
19020 !C as chosen axis
19021       vectube(3)=0.0d0
19022 !C now calculte the distance
19023        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19024 !C now normalize vector
19025       vectube(1)=vectube(1)/tub_r
19026       vectube(2)=vectube(2)/tub_r
19027
19028 !C calculte rdiffrence between r and r0
19029       rdiff=tub_r-tubeR0
19030 !C and its 6 power
19031       rdiff6=rdiff**6.0d0
19032 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19033        sc_aa_tube=sc_aa_tube_par(iti)
19034        sc_bb_tube=sc_bb_tube_par(iti)
19035        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19036        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
19037              6.0d0*sc_bb_tube/rdiff6/rdiff
19038 !C now direction of gg_tube vector
19039          do j=1,3
19040           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19041           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19042          enddo
19043         enddo
19044         do i=itube_start,itube_end
19045           Etube=Etube+enetube(i)+enetube(i+nres)
19046         enddo
19047 !C        print *,"ETUBE", etube
19048         return
19049         end subroutine calctube
19050 !C TO DO 1) add to total energy
19051 !C       2) add to gradient summation
19052 !C       3) add reading parameters (AND of course oppening of PARAM file)
19053 !C       4) add reading the center of tube
19054 !C       5) add COMMONs
19055 !C       6) add to zerograd
19056 !C       7) allocate matrices
19057
19058
19059 !C-----------------------------------------------------------------------
19060 !C-----------------------------------------------------------
19061 !C This subroutine is to mimic the histone like structure but as well can be
19062 !C utilizet to nanostructures (infinit) small modification has to be used to
19063 !C make it finite (z gradient at the ends has to be changes as well as the x,y
19064 !C gradient has to be modified at the ends
19065 !C The energy function is Kihara potential
19066 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
19067 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
19068 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
19069 !C simple Kihara potential
19070       subroutine calctube2(Etube)
19071             real(kind=8),dimension(3) :: vectube
19072       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19073        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
19074        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
19075       integer:: i,j,iti
19076       Etube=0.0d0
19077       do i=itube_start,itube_end
19078         enetube(i)=0.0d0
19079         enetube(i+nres)=0.0d0
19080       enddo
19081 !C first we calculate the distance from tube center
19082 !C first sugare-phosphate group for NARES this would be peptide group
19083 !C for UNRES
19084        do i=itube_start,itube_end
19085 !C lets ommit dummy atoms for now
19086
19087        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19088 !C now calculate distance from center of tube and direction vectors
19089 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19090 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19091 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19092 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19093       xmin=boxxsize
19094       ymin=boxysize
19095         do j=-1,1
19096          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19097          vectube(1)=vectube(1)+boxxsize*j
19098          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19099          vectube(2)=vectube(2)+boxysize*j
19100
19101          xminact=abs(vectube(1)-tubecenter(1))
19102          yminact=abs(vectube(2)-tubecenter(2))
19103            if (xmin.gt.xminact) then
19104             xmin=xminact
19105             xtemp=vectube(1)
19106            endif
19107            if (ymin.gt.yminact) then
19108              ymin=yminact
19109              ytemp=vectube(2)
19110             endif
19111          enddo
19112       vectube(1)=xtemp
19113       vectube(2)=ytemp
19114       vectube(1)=vectube(1)-tubecenter(1)
19115       vectube(2)=vectube(2)-tubecenter(2)
19116
19117 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19118 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19119
19120 !C as the tube is infinity we do not calculate the Z-vector use of Z
19121 !C as chosen axis
19122       vectube(3)=0.0d0
19123 !C now calculte the distance
19124        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19125 !C now normalize vector
19126       vectube(1)=vectube(1)/tub_r
19127       vectube(2)=vectube(2)/tub_r
19128 !C calculte rdiffrence between r and r0
19129       rdiff=tub_r-tubeR0
19130 !C and its 6 power
19131       rdiff6=rdiff**6.0d0
19132 !C THIS FRAGMENT MAKES TUBE FINITE
19133         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19134         if (positi.le.0) positi=positi+boxzsize
19135 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19136 !c for each residue check if it is in lipid or lipid water border area
19137 !C       respos=mod(c(3,i+nres),boxzsize)
19138 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19139        if ((positi.gt.bordtubebot)  &
19140         .and.(positi.lt.bordtubetop)) then
19141 !C the energy transfer exist
19142         if (positi.lt.buftubebot) then
19143          fracinbuf=1.0d0-  &
19144            ((positi-bordtubebot)/tubebufthick)
19145 !C lipbufthick is thickenes of lipid buffore
19146          sstube=sscalelip(fracinbuf)
19147          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19148 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19149          enetube(i)=enetube(i)+sstube*tubetranenepep
19150 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19151 !C     &+ssgradtube*tubetranene(itype(i,1))
19152 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19153 !C     &+ssgradtube*tubetranene(itype(i,1))
19154 !C         print *,"doing sccale for lower part"
19155         elseif (positi.gt.buftubetop) then
19156          fracinbuf=1.0d0-  &
19157         ((bordtubetop-positi)/tubebufthick)
19158          sstube=sscalelip(fracinbuf)
19159          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19160          enetube(i)=enetube(i)+sstube*tubetranenepep
19161 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19162 !C     &+ssgradtube*tubetranene(itype(i,1))
19163 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19164 !C     &+ssgradtube*tubetranene(itype(i,1))
19165 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19166         else
19167          sstube=1.0d0
19168          ssgradtube=0.0d0
19169          enetube(i)=enetube(i)+sstube*tubetranenepep
19170 !C         print *,"I am in true lipid"
19171         endif
19172         else
19173 !C          sstube=0.0d0
19174 !C          ssgradtube=0.0d0
19175         cycle
19176         endif ! if in lipid or buffor
19177
19178 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19179        enetube(i)=enetube(i)+sstube* &
19180         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
19181 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19182 !C       print *,rdiff,rdiff6,pep_aa_tube
19183 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19184 !C now we calculate gradient
19185        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
19186              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
19187 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19188 !C     &rdiff,fac
19189
19190 !C now direction of gg_tube vector
19191        do j=1,3
19192         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19193         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19194         enddo
19195          gg_tube(3,i)=gg_tube(3,i)  &
19196        +ssgradtube*enetube(i)/sstube/2.0d0
19197          gg_tube(3,i-1)= gg_tube(3,i-1)  &
19198        +ssgradtube*enetube(i)/sstube/2.0d0
19199
19200         enddo
19201 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19202 !C        print *,gg_tube(1,0),"TU"
19203         do i=itube_start,itube_end
19204 !C Lets not jump over memory as we use many times iti
19205          iti=itype(i,1)
19206 !C lets ommit dummy atoms for now
19207          if ((iti.eq.ntyp1) &
19208 !!C in UNRES uncomment the line below as GLY has no side-chain...
19209            .or.(iti.eq.10) &
19210           ) cycle
19211           vectube(1)=c(1,i+nres)
19212           vectube(1)=mod(vectube(1),boxxsize)
19213           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19214           vectube(2)=c(2,i+nres)
19215           vectube(2)=mod(vectube(2),boxysize)
19216           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19217
19218       vectube(1)=vectube(1)-tubecenter(1)
19219       vectube(2)=vectube(2)-tubecenter(2)
19220 !C THIS FRAGMENT MAKES TUBE FINITE
19221         positi=(mod(c(3,i+nres),boxzsize))
19222         if (positi.le.0) positi=positi+boxzsize
19223 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19224 !c for each residue check if it is in lipid or lipid water border area
19225 !C       respos=mod(c(3,i+nres),boxzsize)
19226 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19227
19228        if ((positi.gt.bordtubebot)  &
19229         .and.(positi.lt.bordtubetop)) then
19230 !C the energy transfer exist
19231         if (positi.lt.buftubebot) then
19232          fracinbuf=1.0d0- &
19233             ((positi-bordtubebot)/tubebufthick)
19234 !C lipbufthick is thickenes of lipid buffore
19235          sstube=sscalelip(fracinbuf)
19236          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19237 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19238          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19239 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19240 !C     &+ssgradtube*tubetranene(itype(i,1))
19241 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19242 !C     &+ssgradtube*tubetranene(itype(i,1))
19243 !C         print *,"doing sccale for lower part"
19244         elseif (positi.gt.buftubetop) then
19245          fracinbuf=1.0d0- &
19246         ((bordtubetop-positi)/tubebufthick)
19247
19248          sstube=sscalelip(fracinbuf)
19249          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19250          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19251 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19252 !C     &+ssgradtube*tubetranene(itype(i,1))
19253 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19254 !C     &+ssgradtube*tubetranene(itype(i,1))
19255 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19256         else
19257          sstube=1.0d0
19258          ssgradtube=0.0d0
19259          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19260 !C         print *,"I am in true lipid"
19261         endif
19262         else
19263 !C          sstube=0.0d0
19264 !C          ssgradtube=0.0d0
19265         cycle
19266         endif ! if in lipid or buffor
19267 !CEND OF FINITE FRAGMENT
19268 !C as the tube is infinity we do not calculate the Z-vector use of Z
19269 !C as chosen axis
19270       vectube(3)=0.0d0
19271 !C now calculte the distance
19272        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19273 !C now normalize vector
19274       vectube(1)=vectube(1)/tub_r
19275       vectube(2)=vectube(2)/tub_r
19276 !C calculte rdiffrence between r and r0
19277       rdiff=tub_r-tubeR0
19278 !C and its 6 power
19279       rdiff6=rdiff**6.0d0
19280 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19281        sc_aa_tube=sc_aa_tube_par(iti)
19282        sc_bb_tube=sc_bb_tube_par(iti)
19283        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19284                        *sstube+enetube(i+nres)
19285 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19286 !C now we calculate gradient
19287        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19288             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19289 !C now direction of gg_tube vector
19290          do j=1,3
19291           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19292           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19293          enddo
19294          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19295        +ssgradtube*enetube(i+nres)/sstube
19296          gg_tube(3,i-1)= gg_tube(3,i-1) &
19297        +ssgradtube*enetube(i+nres)/sstube
19298
19299         enddo
19300         do i=itube_start,itube_end
19301           Etube=Etube+enetube(i)+enetube(i+nres)
19302         enddo
19303 !C        print *,"ETUBE", etube
19304         return
19305         end subroutine calctube2
19306 !=====================================================================================================================================
19307       subroutine calcnano(Etube)
19308       real(kind=8),dimension(3) :: vectube
19309
19310       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19311        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19312        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19313        integer:: i,j,iti,r
19314
19315       Etube=0.0d0
19316 !      print *,itube_start,itube_end,"poczatek"
19317       do i=itube_start,itube_end
19318         enetube(i)=0.0d0
19319         enetube(i+nres)=0.0d0
19320       enddo
19321 !C first we calculate the distance from tube center
19322 !C first sugare-phosphate group for NARES this would be peptide group
19323 !C for UNRES
19324        do i=itube_start,itube_end
19325 !C lets ommit dummy atoms for now
19326        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19327 !C now calculate distance from center of tube and direction vectors
19328       xmin=boxxsize
19329       ymin=boxysize
19330       zmin=boxzsize
19331
19332         do j=-1,1
19333          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19334          vectube(1)=vectube(1)+boxxsize*j
19335          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19336          vectube(2)=vectube(2)+boxysize*j
19337          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19338          vectube(3)=vectube(3)+boxzsize*j
19339
19340
19341          xminact=dabs(vectube(1)-tubecenter(1))
19342          yminact=dabs(vectube(2)-tubecenter(2))
19343          zminact=dabs(vectube(3)-tubecenter(3))
19344
19345            if (xmin.gt.xminact) then
19346             xmin=xminact
19347             xtemp=vectube(1)
19348            endif
19349            if (ymin.gt.yminact) then
19350              ymin=yminact
19351              ytemp=vectube(2)
19352             endif
19353            if (zmin.gt.zminact) then
19354              zmin=zminact
19355              ztemp=vectube(3)
19356             endif
19357          enddo
19358       vectube(1)=xtemp
19359       vectube(2)=ytemp
19360       vectube(3)=ztemp
19361
19362       vectube(1)=vectube(1)-tubecenter(1)
19363       vectube(2)=vectube(2)-tubecenter(2)
19364       vectube(3)=vectube(3)-tubecenter(3)
19365
19366 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19367 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19368 !C as the tube is infinity we do not calculate the Z-vector use of Z
19369 !C as chosen axis
19370 !C      vectube(3)=0.0d0
19371 !C now calculte the distance
19372        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19373 !C now normalize vector
19374       vectube(1)=vectube(1)/tub_r
19375       vectube(2)=vectube(2)/tub_r
19376       vectube(3)=vectube(3)/tub_r
19377 !C calculte rdiffrence between r and r0
19378       rdiff=tub_r-tubeR0
19379 !C and its 6 power
19380       rdiff6=rdiff**6.0d0
19381 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19382        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19383 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19384 !C       print *,rdiff,rdiff6,pep_aa_tube
19385 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19386 !C now we calculate gradient
19387        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19388             6.0d0*pep_bb_tube)/rdiff6/rdiff
19389 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19390 !C     &rdiff,fac
19391          if (acavtubpep.eq.0.0d0) then
19392 !C go to 667
19393          enecavtube(i)=0.0
19394          faccav=0.0
19395          else
19396          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19397          enecavtube(i)=  &
19398         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19399         /denominator
19400          enecavtube(i)=0.0
19401          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19402         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19403         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19404         /denominator**2.0d0
19405 !C         faccav=0.0
19406 !C         fac=fac+faccav
19407 !C 667     continue
19408          endif
19409           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19410         do j=1,3
19411         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19412         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19413         enddo
19414         enddo
19415
19416        do i=itube_start,itube_end
19417         enecavtube(i)=0.0d0
19418 !C Lets not jump over memory as we use many times iti
19419          iti=itype(i,1)
19420 !C lets ommit dummy atoms for now
19421          if ((iti.eq.ntyp1) &
19422 !C in UNRES uncomment the line below as GLY has no side-chain...
19423 !C      .or.(iti.eq.10)
19424          ) cycle
19425       xmin=boxxsize
19426       ymin=boxysize
19427       zmin=boxzsize
19428         do j=-1,1
19429          vectube(1)=dmod((c(1,i+nres)),boxxsize)
19430          vectube(1)=vectube(1)+boxxsize*j
19431          vectube(2)=dmod((c(2,i+nres)),boxysize)
19432          vectube(2)=vectube(2)+boxysize*j
19433          vectube(3)=dmod((c(3,i+nres)),boxzsize)
19434          vectube(3)=vectube(3)+boxzsize*j
19435
19436
19437          xminact=dabs(vectube(1)-tubecenter(1))
19438          yminact=dabs(vectube(2)-tubecenter(2))
19439          zminact=dabs(vectube(3)-tubecenter(3))
19440
19441            if (xmin.gt.xminact) then
19442             xmin=xminact
19443             xtemp=vectube(1)
19444            endif
19445            if (ymin.gt.yminact) then
19446              ymin=yminact
19447              ytemp=vectube(2)
19448             endif
19449            if (zmin.gt.zminact) then
19450              zmin=zminact
19451              ztemp=vectube(3)
19452             endif
19453          enddo
19454       vectube(1)=xtemp
19455       vectube(2)=ytemp
19456       vectube(3)=ztemp
19457
19458 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19459 !C     &     tubecenter(2)
19460       vectube(1)=vectube(1)-tubecenter(1)
19461       vectube(2)=vectube(2)-tubecenter(2)
19462       vectube(3)=vectube(3)-tubecenter(3)
19463 !C now calculte the distance
19464        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19465 !C now normalize vector
19466       vectube(1)=vectube(1)/tub_r
19467       vectube(2)=vectube(2)/tub_r
19468       vectube(3)=vectube(3)/tub_r
19469
19470 !C calculte rdiffrence between r and r0
19471       rdiff=tub_r-tubeR0
19472 !C and its 6 power
19473       rdiff6=rdiff**6.0d0
19474        sc_aa_tube=sc_aa_tube_par(iti)
19475        sc_bb_tube=sc_bb_tube_par(iti)
19476        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19477 !C       enetube(i+nres)=0.0d0
19478 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19479 !C now we calculate gradient
19480        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
19481             6.0d0*sc_bb_tube/rdiff6/rdiff
19482 !C       fac=0.0
19483 !C now direction of gg_tube vector
19484 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
19485          if (acavtub(iti).eq.0.0d0) then
19486 !C go to 667
19487          enecavtube(i+nres)=0.0d0
19488          faccav=0.0d0
19489          else
19490          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
19491          enecavtube(i+nres)=   &
19492         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
19493         /denominator
19494 !C         enecavtube(i)=0.0
19495          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
19496         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
19497         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
19498         /denominator**2.0d0
19499 !C         faccav=0.0
19500          fac=fac+faccav
19501 !C 667     continue
19502          endif
19503 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
19504 !C     &   enecavtube(i),faccav
19505 !C         print *,"licz=",
19506 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
19507 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
19508          do j=1,3
19509           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19510           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19511          enddo
19512           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
19513         enddo
19514
19515
19516
19517         do i=itube_start,itube_end
19518           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19519          +enecavtube(i+nres)
19520         enddo
19521 !        do i=1,20
19522 !         print *,"begin", i,"a"
19523 !         do r=1,10000
19524 !          rdiff=r/100.0d0
19525 !          rdiff6=rdiff**6.0d0
19526 !          sc_aa_tube=sc_aa_tube_par(i)
19527 !          sc_bb_tube=sc_bb_tube_par(i)
19528 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19529 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19530 !          enecavtube(i)=   &
19531 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19532 !         /denominator
19533
19534 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19535 !         enddo
19536 !         print *,"end",i,"a"
19537 !        enddo
19538 !C        print *,"ETUBE", etube
19539         return
19540         end subroutine calcnano
19541
19542 !===============================================
19543 !--------------------------------------------------------------------------------
19544 !C first for shielding is setting of function of side-chains
19545
19546        subroutine set_shield_fac2
19547        real(kind=8) :: div77_81=0.974996043d0, &
19548         div4_81=0.2222222222d0
19549        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19550          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19551          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19552          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19553 !C the vector between center of side_chain and peptide group
19554        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19555          pept_group,costhet_grad,cosphi_grad_long, &
19556          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19557          sh_frac_dist_grad,pep_side
19558         integer i,j,k
19559 !C      write(2,*) "ivec",ivec_start,ivec_end
19560       do i=1,nres
19561         fac_shield(i)=0.0d0
19562         ishield_list(i)=0
19563         do j=1,3
19564         grad_shield(j,i)=0.0d0
19565         enddo
19566       enddo
19567       do i=ivec_start,ivec_end
19568 !C      do i=1,nres-1
19569 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19570 !      ishield_list(i)=0
19571       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19572 !Cif there two consequtive dummy atoms there is no peptide group between them
19573 !C the line below has to be changed for FGPROC>1
19574       VolumeTotal=0.0
19575       do k=1,nres
19576        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19577        dist_pep_side=0.0
19578        dist_side_calf=0.0
19579        do j=1,3
19580 !C first lets set vector conecting the ithe side-chain with kth side-chain
19581       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19582 !C      pep_side(j)=2.0d0
19583 !C and vector conecting the side-chain with its proper calfa
19584       side_calf(j)=c(j,k+nres)-c(j,k)
19585 !C      side_calf(j)=2.0d0
19586       pept_group(j)=c(j,i)-c(j,i+1)
19587 !C lets have their lenght
19588       dist_pep_side=pep_side(j)**2+dist_pep_side
19589       dist_side_calf=dist_side_calf+side_calf(j)**2
19590       dist_pept_group=dist_pept_group+pept_group(j)**2
19591       enddo
19592        dist_pep_side=sqrt(dist_pep_side)
19593        dist_pept_group=sqrt(dist_pept_group)
19594        dist_side_calf=sqrt(dist_side_calf)
19595       do j=1,3
19596         pep_side_norm(j)=pep_side(j)/dist_pep_side
19597         side_calf_norm(j)=dist_side_calf
19598       enddo
19599 !C now sscale fraction
19600        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19601 !       print *,buff_shield,"buff",sh_frac_dist
19602 !C now sscale
19603         if (sh_frac_dist.le.0.0) cycle
19604 !C        print *,ishield_list(i),i
19605 !C If we reach here it means that this side chain reaches the shielding sphere
19606 !C Lets add him to the list for gradient
19607         ishield_list(i)=ishield_list(i)+1
19608 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19609 !C this list is essential otherwise problem would be O3
19610         shield_list(ishield_list(i),i)=k
19611 !C Lets have the sscale value
19612         if (sh_frac_dist.gt.1.0) then
19613          scale_fac_dist=1.0d0
19614          do j=1,3
19615          sh_frac_dist_grad(j)=0.0d0
19616          enddo
19617         else
19618          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19619                         *(2.0d0*sh_frac_dist-3.0d0)
19620          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19621                        /dist_pep_side/buff_shield*0.5d0
19622          do j=1,3
19623          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19624 !C         sh_frac_dist_grad(j)=0.0d0
19625 !C         scale_fac_dist=1.0d0
19626 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19627 !C     &                    sh_frac_dist_grad(j)
19628          enddo
19629         endif
19630 !C this is what is now we have the distance scaling now volume...
19631       short=short_r_sidechain(itype(k,1))
19632       long=long_r_sidechain(itype(k,1))
19633       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19634       sinthet=short/dist_pep_side*costhet
19635 !      print *,"SORT",short,long,sinthet,costhet
19636 !C now costhet_grad
19637 !C       costhet=0.6d0
19638 !C       sinthet=0.8
19639        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19640 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19641 !C     &             -short/dist_pep_side**2/costhet)
19642 !C       costhet_fac=0.0d0
19643        do j=1,3
19644          costhet_grad(j)=costhet_fac*pep_side(j)
19645        enddo
19646 !C remember for the final gradient multiply costhet_grad(j)
19647 !C for side_chain by factor -2 !
19648 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19649 !C pep_side0pept_group is vector multiplication
19650       pep_side0pept_group=0.0d0
19651       do j=1,3
19652       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19653       enddo
19654       cosalfa=(pep_side0pept_group/ &
19655       (dist_pep_side*dist_side_calf))
19656       fac_alfa_sin=1.0d0-cosalfa**2
19657       fac_alfa_sin=dsqrt(fac_alfa_sin)
19658       rkprim=fac_alfa_sin*(long-short)+short
19659 !C      rkprim=short
19660
19661 !C now costhet_grad
19662        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19663 !C       cosphi=0.6
19664        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19665        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19666            dist_pep_side**2)
19667 !C       sinphi=0.8
19668        do j=1,3
19669          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19670       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19671       *(long-short)/fac_alfa_sin*cosalfa/ &
19672       ((dist_pep_side*dist_side_calf))* &
19673       ((side_calf(j))-cosalfa* &
19674       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19675 !C       cosphi_grad_long(j)=0.0d0
19676         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19677       *(long-short)/fac_alfa_sin*cosalfa &
19678       /((dist_pep_side*dist_side_calf))* &
19679       (pep_side(j)- &
19680       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19681 !C       cosphi_grad_loc(j)=0.0d0
19682        enddo
19683 !C      print *,sinphi,sinthet
19684       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19685                          /VSolvSphere_div
19686 !C     &                    *wshield
19687 !C now the gradient...
19688       do j=1,3
19689       grad_shield(j,i)=grad_shield(j,i) &
19690 !C gradient po skalowaniu
19691                      +(sh_frac_dist_grad(j)*VofOverlap &
19692 !C  gradient po costhet
19693             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19694         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19695             sinphi/sinthet*costhet*costhet_grad(j) &
19696            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19697         )*wshield
19698 !C grad_shield_side is Cbeta sidechain gradient
19699       grad_shield_side(j,ishield_list(i),i)=&
19700              (sh_frac_dist_grad(j)*-2.0d0&
19701              *VofOverlap&
19702             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19703        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19704             sinphi/sinthet*costhet*costhet_grad(j)&
19705            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19706             )*wshield
19707 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
19708 !            sinphi/sinthet,&
19709 !           +sinthet/sinphi,"HERE"
19710        grad_shield_loc(j,ishield_list(i),i)=   &
19711             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19712       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
19713             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
19714              ))&
19715              *wshield
19716 !         print *,grad_shield_loc(j,ishield_list(i),i)
19717       enddo
19718       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
19719       enddo
19720       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
19721
19722 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
19723       enddo
19724       return
19725       end subroutine set_shield_fac2
19726 !----------------------------------------------------------------------------
19727 ! SOUBROUTINE FOR AFM
19728        subroutine AFMvel(Eafmforce)
19729        use MD_data, only:totTafm
19730       real(kind=8),dimension(3) :: diffafm
19731       real(kind=8) :: afmdist,Eafmforce
19732        integer :: i
19733 !C Only for check grad COMMENT if not used for checkgrad
19734 !C      totT=3.0d0
19735 !C--------------------------------------------------------
19736 !C      print *,"wchodze"
19737       afmdist=0.0d0
19738       Eafmforce=0.0d0
19739       do i=1,3
19740       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19741       afmdist=afmdist+diffafm(i)**2
19742       enddo
19743       afmdist=dsqrt(afmdist)
19744 !      totTafm=3.0
19745       Eafmforce=0.5d0*forceAFMconst &
19746       *(distafminit+totTafm*velAFMconst-afmdist)**2
19747 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
19748       do i=1,3
19749       gradafm(i,afmend-1)=-forceAFMconst* &
19750        (distafminit+totTafm*velAFMconst-afmdist) &
19751        *diffafm(i)/afmdist
19752       gradafm(i,afmbeg-1)=forceAFMconst* &
19753       (distafminit+totTafm*velAFMconst-afmdist) &
19754       *diffafm(i)/afmdist
19755       enddo
19756 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
19757       return
19758       end subroutine AFMvel
19759 !---------------------------------------------------------
19760        subroutine AFMforce(Eafmforce)
19761
19762       real(kind=8),dimension(3) :: diffafm
19763 !      real(kind=8) ::afmdist
19764       real(kind=8) :: afmdist,Eafmforce
19765       integer :: i
19766       afmdist=0.0d0
19767       Eafmforce=0.0d0
19768       do i=1,3
19769       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19770       afmdist=afmdist+diffafm(i)**2
19771       enddo
19772       afmdist=dsqrt(afmdist)
19773 !      print *,afmdist,distafminit
19774       Eafmforce=-forceAFMconst*(afmdist-distafminit)
19775       do i=1,3
19776       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
19777       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
19778       enddo
19779 !C      print *,'AFM',Eafmforce
19780       return
19781       end subroutine AFMforce
19782
19783 !-----------------------------------------------------------------------------
19784 #ifdef WHAM
19785       subroutine read_ssHist
19786 !      implicit none
19787 !      Includes
19788 !      include 'DIMENSIONS'
19789 !      include "DIMENSIONS.FREE"
19790 !      include 'COMMON.FREE'
19791 !     Local variables
19792       integer :: i,j
19793       character(len=80) :: controlcard
19794
19795       do i=1,dyn_nssHist
19796         call card_concat(controlcard,.true.)
19797         read(controlcard,*) &
19798              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
19799       enddo
19800
19801       return
19802       end subroutine read_ssHist
19803 #endif
19804 !-----------------------------------------------------------------------------
19805       integer function indmat(i,j)
19806 !el
19807 ! get the position of the jth ijth fragment of the chain coordinate system
19808 ! in the fromto array.
19809         integer :: i,j
19810
19811         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
19812       return
19813       end function indmat
19814 !-----------------------------------------------------------------------------
19815       real(kind=8) function sigm(x)
19816 !el
19817        real(kind=8) :: x
19818         sigm=0.25d0*x
19819       return
19820       end function sigm
19821 !-----------------------------------------------------------------------------
19822 !-----------------------------------------------------------------------------
19823       subroutine alloc_ener_arrays
19824 !EL Allocation of arrays used by module energy
19825       use MD_data, only: mset
19826 !el local variables
19827       integer :: i,j
19828
19829       if(nres.lt.100) then
19830         maxconts=nres
19831       elseif(nres.lt.200) then
19832         maxconts=0.8*nres      ! Max. number of contacts per residue
19833       else
19834         maxconts=0.6*nres ! (maxconts=maxres/4)
19835       endif
19836       maxcont=12*nres      ! Max. number of SC contacts
19837       maxvar=6*nres      ! Max. number of variables
19838 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19839       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19840 !----------------------
19841 ! arrays in subroutine init_int_table
19842 !el#ifdef MPI
19843 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
19844 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
19845 !el#endif
19846       allocate(nint_gr(nres))
19847       allocate(nscp_gr(nres))
19848       allocate(ielstart(nres))
19849       allocate(ielend(nres))
19850 !(maxres)
19851       allocate(istart(nres,maxint_gr))
19852       allocate(iend(nres,maxint_gr))
19853 !(maxres,maxint_gr)
19854       allocate(iscpstart(nres,maxint_gr))
19855       allocate(iscpend(nres,maxint_gr))
19856 !(maxres,maxint_gr)
19857       allocate(ielstart_vdw(nres))
19858       allocate(ielend_vdw(nres))
19859 !(maxres)
19860       allocate(nint_gr_nucl(nres))
19861       allocate(nscp_gr_nucl(nres))
19862       allocate(ielstart_nucl(nres))
19863       allocate(ielend_nucl(nres))
19864 !(maxres)
19865       allocate(istart_nucl(nres,maxint_gr))
19866       allocate(iend_nucl(nres,maxint_gr))
19867 !(maxres,maxint_gr)
19868       allocate(iscpstart_nucl(nres,maxint_gr))
19869       allocate(iscpend_nucl(nres,maxint_gr))
19870 !(maxres,maxint_gr)
19871       allocate(ielstart_vdw_nucl(nres))
19872       allocate(ielend_vdw_nucl(nres))
19873
19874       allocate(lentyp(0:nfgtasks-1))
19875 !(0:maxprocs-1)
19876 !----------------------
19877 ! commom.contacts
19878 !      common /contacts/
19879       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
19880       allocate(icont(2,maxcont))
19881 !(2,maxcont)
19882 !      common /contacts1/
19883       allocate(num_cont(0:nres+4))
19884 !(maxres)
19885       allocate(jcont(maxconts,nres))
19886 !(maxconts,maxres)
19887       allocate(facont(maxconts,nres))
19888 !(maxconts,maxres)
19889       allocate(gacont(3,maxconts,nres))
19890 !(3,maxconts,maxres)
19891 !      common /contacts_hb/
19892       allocate(gacontp_hb1(3,maxconts,nres))
19893       allocate(gacontp_hb2(3,maxconts,nres))
19894       allocate(gacontp_hb3(3,maxconts,nres))
19895       allocate(gacontm_hb1(3,maxconts,nres))
19896       allocate(gacontm_hb2(3,maxconts,nres))
19897       allocate(gacontm_hb3(3,maxconts,nres))
19898       allocate(gacont_hbr(3,maxconts,nres))
19899       allocate(grij_hb_cont(3,maxconts,nres))
19900 !(3,maxconts,maxres)
19901       allocate(facont_hb(maxconts,nres))
19902
19903       allocate(ees0p(maxconts,nres))
19904       allocate(ees0m(maxconts,nres))
19905       allocate(d_cont(maxconts,nres))
19906       allocate(ees0plist(maxconts,nres))
19907
19908 !(maxconts,maxres)
19909       allocate(num_cont_hb(nres))
19910 !(maxres)
19911       allocate(jcont_hb(maxconts,nres))
19912 !(maxconts,maxres)
19913 !      common /rotat/
19914       allocate(Ug(2,2,nres))
19915       allocate(Ugder(2,2,nres))
19916       allocate(Ug2(2,2,nres))
19917       allocate(Ug2der(2,2,nres))
19918 !(2,2,maxres)
19919       allocate(obrot(2,nres))
19920       allocate(obrot2(2,nres))
19921       allocate(obrot_der(2,nres))
19922       allocate(obrot2_der(2,nres))
19923 !(2,maxres)
19924 !      common /precomp1/
19925       allocate(mu(2,nres))
19926       allocate(muder(2,nres))
19927       allocate(Ub2(2,nres))
19928       Ub2(1,:)=0.0d0
19929       Ub2(2,:)=0.0d0
19930       allocate(Ub2der(2,nres))
19931       allocate(Ctobr(2,nres))
19932       allocate(Ctobrder(2,nres))
19933       allocate(Dtobr2(2,nres))
19934       allocate(Dtobr2der(2,nres))
19935 !(2,maxres)
19936       allocate(EUg(2,2,nres))
19937       allocate(EUgder(2,2,nres))
19938       allocate(CUg(2,2,nres))
19939       allocate(CUgder(2,2,nres))
19940       allocate(DUg(2,2,nres))
19941       allocate(Dugder(2,2,nres))
19942       allocate(DtUg2(2,2,nres))
19943       allocate(DtUg2der(2,2,nres))
19944 !(2,2,maxres)
19945 !      common /precomp2/
19946       allocate(Ug2Db1t(2,nres))
19947       allocate(Ug2Db1tder(2,nres))
19948       allocate(CUgb2(2,nres))
19949       allocate(CUgb2der(2,nres))
19950 !(2,maxres)
19951       allocate(EUgC(2,2,nres))
19952       allocate(EUgCder(2,2,nres))
19953       allocate(EUgD(2,2,nres))
19954       allocate(EUgDder(2,2,nres))
19955       allocate(DtUg2EUg(2,2,nres))
19956       allocate(Ug2DtEUg(2,2,nres))
19957 !(2,2,maxres)
19958       allocate(Ug2DtEUgder(2,2,2,nres))
19959       allocate(DtUg2EUgder(2,2,2,nres))
19960 !(2,2,2,maxres)
19961 !      common /rotat_old/
19962       allocate(costab(nres))
19963       allocate(sintab(nres))
19964       allocate(costab2(nres))
19965       allocate(sintab2(nres))
19966 !(maxres)
19967 !      common /dipmat/
19968       allocate(a_chuj(2,2,maxconts,nres))
19969 !(2,2,maxconts,maxres)(maxconts=maxres/4)
19970       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
19971 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
19972 !      common /contdistrib/
19973       allocate(ncont_sent(nres))
19974       allocate(ncont_recv(nres))
19975
19976       allocate(iat_sent(nres))
19977 !(maxres)
19978       allocate(iint_sent(4,nres,nres))
19979       allocate(iint_sent_local(4,nres,nres))
19980 !(4,maxres,maxres)
19981       allocate(iturn3_sent(4,0:nres+4))
19982       allocate(iturn4_sent(4,0:nres+4))
19983       allocate(iturn3_sent_local(4,nres))
19984       allocate(iturn4_sent_local(4,nres))
19985 !(4,maxres)
19986       allocate(itask_cont_from(0:nfgtasks-1))
19987       allocate(itask_cont_to(0:nfgtasks-1))
19988 !(0:max_fg_procs-1)
19989
19990
19991
19992 !----------------------
19993 ! commom.deriv;
19994 !      common /derivat/
19995       allocate(dcdv(6,maxdim))
19996       allocate(dxdv(6,maxdim))
19997 !(6,maxdim)
19998       allocate(dxds(6,nres))
19999 !(6,maxres)
20000       allocate(gradx(3,-1:nres,0:2))
20001       allocate(gradc(3,-1:nres,0:2))
20002 !(3,maxres,2)
20003       allocate(gvdwx(3,-1:nres))
20004       allocate(gvdwc(3,-1:nres))
20005       allocate(gelc(3,-1:nres))
20006       allocate(gelc_long(3,-1:nres))
20007       allocate(gvdwpp(3,-1:nres))
20008       allocate(gvdwc_scpp(3,-1:nres))
20009       allocate(gradx_scp(3,-1:nres))
20010       allocate(gvdwc_scp(3,-1:nres))
20011       allocate(ghpbx(3,-1:nres))
20012       allocate(ghpbc(3,-1:nres))
20013       allocate(gradcorr(3,-1:nres))
20014       allocate(gradcorr_long(3,-1:nres))
20015       allocate(gradcorr5_long(3,-1:nres))
20016       allocate(gradcorr6_long(3,-1:nres))
20017       allocate(gcorr6_turn_long(3,-1:nres))
20018       allocate(gradxorr(3,-1:nres))
20019       allocate(gradcorr5(3,-1:nres))
20020       allocate(gradcorr6(3,-1:nres))
20021       allocate(gliptran(3,-1:nres))
20022       allocate(gliptranc(3,-1:nres))
20023       allocate(gliptranx(3,-1:nres))
20024       allocate(gshieldx(3,-1:nres))
20025       allocate(gshieldc(3,-1:nres))
20026       allocate(gshieldc_loc(3,-1:nres))
20027       allocate(gshieldx_ec(3,-1:nres))
20028       allocate(gshieldc_ec(3,-1:nres))
20029       allocate(gshieldc_loc_ec(3,-1:nres))
20030       allocate(gshieldx_t3(3,-1:nres))
20031       allocate(gshieldc_t3(3,-1:nres))
20032       allocate(gshieldc_loc_t3(3,-1:nres))
20033       allocate(gshieldx_t4(3,-1:nres))
20034       allocate(gshieldc_t4(3,-1:nres))
20035       allocate(gshieldc_loc_t4(3,-1:nres))
20036       allocate(gshieldx_ll(3,-1:nres))
20037       allocate(gshieldc_ll(3,-1:nres))
20038       allocate(gshieldc_loc_ll(3,-1:nres))
20039       allocate(grad_shield(3,-1:nres))
20040       allocate(gg_tube_sc(3,-1:nres))
20041       allocate(gg_tube(3,-1:nres))
20042       allocate(gradafm(3,-1:nres))
20043       allocate(gradb_nucl(3,-1:nres))
20044       allocate(gradbx_nucl(3,-1:nres))
20045       allocate(gvdwpsb1(3,-1:nres))
20046       allocate(gelpp(3,-1:nres))
20047       allocate(gvdwpsb(3,-1:nres))
20048       allocate(gelsbc(3,-1:nres))
20049       allocate(gelsbx(3,-1:nres))
20050       allocate(gvdwsbx(3,-1:nres))
20051       allocate(gvdwsbc(3,-1:nres))
20052       allocate(gsbloc(3,-1:nres))
20053       allocate(gsblocx(3,-1:nres))
20054       allocate(gradcorr_nucl(3,-1:nres))
20055       allocate(gradxorr_nucl(3,-1:nres))
20056       allocate(gradcorr3_nucl(3,-1:nres))
20057       allocate(gradxorr3_nucl(3,-1:nres))
20058       allocate(gvdwpp_nucl(3,-1:nres))
20059       allocate(gradpepcat(3,-1:nres))
20060       allocate(gradpepcatx(3,-1:nres))
20061       allocate(gradcatcat(3,-1:nres))
20062 !(3,maxres)
20063       allocate(grad_shield_side(3,maxcontsshi,-1:nres))
20064       allocate(grad_shield_loc(3,maxcontsshi,-1:nres))
20065 ! grad for shielding surroing
20066       allocate(gloc(0:maxvar,0:2))
20067       allocate(gloc_x(0:maxvar,2))
20068 !(maxvar,2)
20069       allocate(gel_loc(3,-1:nres))
20070       allocate(gel_loc_long(3,-1:nres))
20071       allocate(gcorr3_turn(3,-1:nres))
20072       allocate(gcorr4_turn(3,-1:nres))
20073       allocate(gcorr6_turn(3,-1:nres))
20074       allocate(gradb(3,-1:nres))
20075       allocate(gradbx(3,-1:nres))
20076 !(3,maxres)
20077       allocate(gel_loc_loc(maxvar))
20078       allocate(gel_loc_turn3(maxvar))
20079       allocate(gel_loc_turn4(maxvar))
20080       allocate(gel_loc_turn6(maxvar))
20081       allocate(gcorr_loc(maxvar))
20082       allocate(g_corr5_loc(maxvar))
20083       allocate(g_corr6_loc(maxvar))
20084 !(maxvar)
20085       allocate(gsccorc(3,-1:nres))
20086       allocate(gsccorx(3,-1:nres))
20087 !(3,maxres)
20088       allocate(gsccor_loc(-1:nres))
20089 !(maxres)
20090       allocate(gvdwx_scbase(3,-1:nres))
20091       allocate(gvdwc_scbase(3,-1:nres))
20092       allocate(gvdwx_pepbase(3,-1:nres))
20093       allocate(gvdwc_pepbase(3,-1:nres))
20094       allocate(gvdwx_scpho(3,-1:nres))
20095       allocate(gvdwc_scpho(3,-1:nres))
20096       allocate(gvdwc_peppho(3,-1:nres))
20097
20098       allocate(dtheta(3,2,-1:nres))
20099 !(3,2,maxres)
20100       allocate(gscloc(3,-1:nres))
20101       allocate(gsclocx(3,-1:nres))
20102 !(3,maxres)
20103       allocate(dphi(3,3,-1:nres))
20104       allocate(dalpha(3,3,-1:nres))
20105       allocate(domega(3,3,-1:nres))
20106 !(3,3,maxres)
20107 !      common /deriv_scloc/
20108       allocate(dXX_C1tab(3,nres))
20109       allocate(dYY_C1tab(3,nres))
20110       allocate(dZZ_C1tab(3,nres))
20111       allocate(dXX_Ctab(3,nres))
20112       allocate(dYY_Ctab(3,nres))
20113       allocate(dZZ_Ctab(3,nres))
20114       allocate(dXX_XYZtab(3,nres))
20115       allocate(dYY_XYZtab(3,nres))
20116       allocate(dZZ_XYZtab(3,nres))
20117 !(3,maxres)
20118 !      common /mpgrad/
20119       allocate(jgrad_start(nres))
20120       allocate(jgrad_end(nres))
20121 !(maxres)
20122 !----------------------
20123
20124 !      common /indices/
20125       allocate(ibond_displ(0:nfgtasks-1))
20126       allocate(ibond_count(0:nfgtasks-1))
20127       allocate(ithet_displ(0:nfgtasks-1))
20128       allocate(ithet_count(0:nfgtasks-1))
20129       allocate(iphi_displ(0:nfgtasks-1))
20130       allocate(iphi_count(0:nfgtasks-1))
20131       allocate(iphi1_displ(0:nfgtasks-1))
20132       allocate(iphi1_count(0:nfgtasks-1))
20133       allocate(ivec_displ(0:nfgtasks-1))
20134       allocate(ivec_count(0:nfgtasks-1))
20135       allocate(iset_displ(0:nfgtasks-1))
20136       allocate(iset_count(0:nfgtasks-1))
20137       allocate(iint_count(0:nfgtasks-1))
20138       allocate(iint_displ(0:nfgtasks-1))
20139 !(0:max_fg_procs-1)
20140 !----------------------
20141 ! common.MD
20142 !      common /mdgrad/
20143       allocate(gcart(3,-1:nres))
20144       allocate(gxcart(3,-1:nres))
20145 !(3,0:MAXRES)
20146       allocate(gradcag(3,-1:nres))
20147       allocate(gradxag(3,-1:nres))
20148 !(3,MAXRES)
20149 !      common /back_constr/
20150 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
20151       allocate(dutheta(nres))
20152       allocate(dugamma(nres))
20153 !(maxres)
20154       allocate(duscdiff(3,nres))
20155       allocate(duscdiffx(3,nres))
20156 !(3,maxres)
20157 !el i io:read_fragments
20158 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
20159 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
20160 !      common /qmeas/
20161 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
20162 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
20163       allocate(mset(0:nprocs))  !(maxprocs/20)
20164       mset(:)=0
20165 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
20166 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
20167       allocate(dUdconst(3,0:nres))
20168       allocate(dUdxconst(3,0:nres))
20169       allocate(dqwol(3,0:nres))
20170       allocate(dxqwol(3,0:nres))
20171 !(3,0:MAXRES)
20172 !----------------------
20173 ! common.sbridge
20174 !      common /sbridge/ in io_common: read_bridge
20175 !el    allocate((:),allocatable :: iss      !(maxss)
20176 !      common /links/  in io_common: read_bridge
20177 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
20178 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
20179 !      common /dyn_ssbond/
20180 ! and side-chain vectors in theta or phi.
20181       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
20182 !(maxres,maxres)
20183 !      do i=1,nres
20184 !        do j=i+1,nres
20185       dyn_ssbond_ij(:,:)=1.0d300
20186 !        enddo
20187 !      enddo
20188
20189 !      if (nss.gt.0) then
20190         allocate(idssb(maxdim),jdssb(maxdim))
20191 !        allocate(newihpb(nss),newjhpb(nss))
20192 !(maxdim)
20193 !      endif
20194       allocate(ishield_list(-1:nres))
20195       allocate(shield_list(maxcontsshi,-1:nres))
20196       allocate(dyn_ss_mask(nres))
20197       allocate(fac_shield(-1:nres))
20198       allocate(enetube(nres*2))
20199       allocate(enecavtube(nres*2))
20200
20201 !(maxres)
20202       dyn_ss_mask(:)=.false.
20203 !----------------------
20204 ! common.sccor
20205 ! Parameters of the SCCOR term
20206 !      common/sccor/
20207 !el in io_conf: parmread
20208 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
20209 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
20210 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
20211 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
20212 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
20213 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
20214 !      allocate(vlor1sccor(maxterm_sccor,20,20))
20215 !      allocate(vlor2sccor(maxterm_sccor,20,20))
20216 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
20217 !----------------
20218       allocate(gloc_sc(3,0:2*nres,0:10))
20219 !(3,0:maxres2,10)maxres2=2*maxres
20220       allocate(dcostau(3,3,3,2*nres))
20221       allocate(dsintau(3,3,3,2*nres))
20222       allocate(dtauangle(3,3,3,2*nres))
20223       allocate(dcosomicron(3,3,3,2*nres))
20224       allocate(domicron(3,3,3,2*nres))
20225 !(3,3,3,maxres2)maxres2=2*maxres
20226 !----------------------
20227 ! common.var
20228 !      common /restr/
20229       allocate(varall(maxvar))
20230 !(maxvar)(maxvar=6*maxres)
20231       allocate(mask_theta(nres))
20232       allocate(mask_phi(nres))
20233       allocate(mask_side(nres))
20234 !(maxres)
20235 !----------------------
20236 ! common.vectors
20237 !      common /vectors/
20238       allocate(uy(3,nres))
20239       allocate(uz(3,nres))
20240 !(3,maxres)
20241       allocate(uygrad(3,3,2,nres))
20242       allocate(uzgrad(3,3,2,nres))
20243 !(3,3,2,maxres)
20244
20245       return
20246       end subroutine alloc_ener_arrays
20247 !-----------------------------------------------------------------
20248       subroutine ebond_nucl(estr_nucl)
20249 !c
20250 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20251 !c
20252
20253       real(kind=8),dimension(3) :: u,ud
20254       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20255       real(kind=8) :: estr_nucl,diff
20256       integer :: iti,i,j,k,nbi
20257       estr_nucl=0.0d0
20258 !C      print *,"I enter ebond"
20259       if (energy_dec) &
20260       write (iout,*) "ibondp_start,ibondp_end",&
20261        ibondp_nucl_start,ibondp_nucl_end
20262       do i=ibondp_nucl_start,ibondp_nucl_end
20263         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20264          itype(i,2).eq.ntyp1_molec(2)) cycle
20265 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20266 !          do j=1,3
20267 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20268 !     &      *dc(j,i-1)/vbld(i)
20269 !          enddo
20270 !          if (energy_dec) write(iout,*)
20271 !     &       "estr1",i,vbld(i),distchainmax,
20272 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20273
20274           diff = vbld(i)-vbldp0_nucl
20275           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20276           vbldp0_nucl,diff,AKP_nucl*diff*diff
20277           estr_nucl=estr_nucl+diff*diff
20278 !          print *,estr_nucl
20279           do j=1,3
20280             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20281           enddo
20282 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20283       enddo
20284       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20285 !      print *,"partial sum", estr_nucl,AKP_nucl
20286
20287       if (energy_dec) &
20288       write (iout,*) "ibondp_start,ibondp_end",&
20289        ibond_nucl_start,ibond_nucl_end
20290
20291       do i=ibond_nucl_start,ibond_nucl_end
20292 !C        print *, "I am stuck",i
20293         iti=itype(i,2)
20294         if (iti.eq.ntyp1_molec(2)) cycle
20295           nbi=nbondterm_nucl(iti)
20296 !C        print *,iti,nbi
20297           if (nbi.eq.1) then
20298             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20299
20300             if (energy_dec) &
20301            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20302            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20303             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20304 !            print *,estr_nucl
20305             do j=1,3
20306               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20307             enddo
20308           else
20309             do j=1,nbi
20310               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20311               ud(j)=aksc_nucl(j,iti)*diff
20312               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20313             enddo
20314             uprod=u(1)
20315             do j=2,nbi
20316               uprod=uprod*u(j)
20317             enddo
20318             usum=0.0d0
20319             usumsqder=0.0d0
20320             do j=1,nbi
20321               uprod1=1.0d0
20322               uprod2=1.0d0
20323               do k=1,nbi
20324                 if (k.ne.j) then
20325                   uprod1=uprod1*u(k)
20326                   uprod2=uprod2*u(k)*u(k)
20327                 endif
20328               enddo
20329               usum=usum+uprod1
20330               usumsqder=usumsqder+ud(j)*uprod2
20331             enddo
20332             estr_nucl=estr_nucl+uprod/usum
20333             do j=1,3
20334              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20335             enddo
20336         endif
20337       enddo
20338 !C      print *,"I am about to leave ebond"
20339       return
20340       end subroutine ebond_nucl
20341
20342 !-----------------------------------------------------------------------------
20343       subroutine ebend_nucl(etheta_nucl)
20344       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20345       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20346       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20347       logical :: lprn=.false., lprn1=.false.
20348 !el local variables
20349       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20350       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20351       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20352 ! local variables for constrains
20353       real(kind=8) :: difi,thetiii
20354        integer itheta
20355       etheta_nucl=0.0D0
20356 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20357       do i=ithet_nucl_start,ithet_nucl_end
20358         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20359         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20360         (itype(i,2).eq.ntyp1_molec(2))) cycle
20361         dethetai=0.0d0
20362         dephii=0.0d0
20363         dephii1=0.0d0
20364         theti2=0.5d0*theta(i)
20365         ityp2=ithetyp_nucl(itype(i-1,2))
20366         do k=1,nntheterm_nucl
20367           coskt(k)=dcos(k*theti2)
20368           sinkt(k)=dsin(k*theti2)
20369         enddo
20370         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20371 #ifdef OSF
20372           phii=phi(i)
20373           if (phii.ne.phii) phii=150.0
20374 #else
20375           phii=phi(i)
20376 #endif
20377           ityp1=ithetyp_nucl(itype(i-2,2))
20378           do k=1,nsingle_nucl
20379             cosph1(k)=dcos(k*phii)
20380             sinph1(k)=dsin(k*phii)
20381           enddo
20382         else
20383           phii=0.0d0
20384           ityp1=nthetyp_nucl+1
20385           do k=1,nsingle_nucl
20386             cosph1(k)=0.0d0
20387             sinph1(k)=0.0d0
20388           enddo
20389         endif
20390
20391         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20392 #ifdef OSF
20393           phii1=phi(i+1)
20394           if (phii1.ne.phii1) phii1=150.0
20395           phii1=pinorm(phii1)
20396 #else
20397           phii1=phi(i+1)
20398 #endif
20399           ityp3=ithetyp_nucl(itype(i,2))
20400           do k=1,nsingle_nucl
20401             cosph2(k)=dcos(k*phii1)
20402             sinph2(k)=dsin(k*phii1)
20403           enddo
20404         else
20405           phii1=0.0d0
20406           ityp3=nthetyp_nucl+1
20407           do k=1,nsingle_nucl
20408             cosph2(k)=0.0d0
20409             sinph2(k)=0.0d0
20410           enddo
20411         endif
20412         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
20413         do k=1,ndouble_nucl
20414           do l=1,k-1
20415             ccl=cosph1(l)*cosph2(k-l)
20416             ssl=sinph1(l)*sinph2(k-l)
20417             scl=sinph1(l)*cosph2(k-l)
20418             csl=cosph1(l)*sinph2(k-l)
20419             cosph1ph2(l,k)=ccl-ssl
20420             cosph1ph2(k,l)=ccl+ssl
20421             sinph1ph2(l,k)=scl+csl
20422             sinph1ph2(k,l)=scl-csl
20423           enddo
20424         enddo
20425         if (lprn) then
20426         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
20427          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
20428         write (iout,*) "coskt and sinkt",nntheterm_nucl
20429         do k=1,nntheterm_nucl
20430           write (iout,*) k,coskt(k),sinkt(k)
20431         enddo
20432         endif
20433         do k=1,ntheterm_nucl
20434           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
20435           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
20436            *coskt(k)
20437           if (lprn)&
20438          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
20439           " ethetai",ethetai
20440         enddo
20441         if (lprn) then
20442         write (iout,*) "cosph and sinph"
20443         do k=1,nsingle_nucl
20444           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
20445         enddo
20446         write (iout,*) "cosph1ph2 and sinph2ph2"
20447         do k=2,ndouble_nucl
20448           do l=1,k-1
20449             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
20450               sinph1ph2(l,k),sinph1ph2(k,l)
20451           enddo
20452         enddo
20453         write(iout,*) "ethetai",ethetai
20454         endif
20455         do m=1,ntheterm2_nucl
20456           do k=1,nsingle_nucl
20457             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
20458               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
20459               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
20460               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
20461             ethetai=ethetai+sinkt(m)*aux
20462             dethetai=dethetai+0.5d0*m*aux*coskt(m)
20463             dephii=dephii+k*sinkt(m)*(&
20464                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
20465                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
20466             dephii1=dephii1+k*sinkt(m)*(&
20467                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
20468                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
20469             if (lprn) &
20470            write (iout,*) "m",m," k",k," bbthet",&
20471               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
20472               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
20473               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
20474               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20475           enddo
20476         enddo
20477         if (lprn) &
20478         write(iout,*) "ethetai",ethetai
20479         do m=1,ntheterm3_nucl
20480           do k=2,ndouble_nucl
20481             do l=1,k-1
20482               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20483                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
20484                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20485                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
20486               ethetai=ethetai+sinkt(m)*aux
20487               dethetai=dethetai+0.5d0*m*coskt(m)*aux
20488               dephii=dephii+l*sinkt(m)*(&
20489                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
20490                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20491                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20492                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20493               dephii1=dephii1+(k-l)*sinkt(m)*( &
20494                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20495                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20496                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
20497                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20498               if (lprn) then
20499               write (iout,*) "m",m," k",k," l",l," ffthet", &
20500                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
20501                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
20502                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
20503                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20504               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
20505                  cosph1ph2(k,l)*sinkt(m),&
20506                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
20507               endif
20508             enddo
20509           enddo
20510         enddo
20511 10      continue
20512         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
20513         i,theta(i)*rad2deg,phii*rad2deg, &
20514         phii1*rad2deg,ethetai
20515         etheta_nucl=etheta_nucl+ethetai
20516 !        print *,i,"partial sum",etheta_nucl
20517         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
20518         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
20519         gloc(nphi+i-2,icg)=wang_nucl*dethetai
20520       enddo
20521       return
20522       end subroutine ebend_nucl
20523 !----------------------------------------------------
20524       subroutine etor_nucl(etors_nucl)
20525 !      implicit real*8 (a-h,o-z)
20526 !      include 'DIMENSIONS'
20527 !      include 'COMMON.VAR'
20528 !      include 'COMMON.GEO'
20529 !      include 'COMMON.LOCAL'
20530 !      include 'COMMON.TORSION'
20531 !      include 'COMMON.INTERACT'
20532 !      include 'COMMON.DERIV'
20533 !      include 'COMMON.CHAIN'
20534 !      include 'COMMON.NAMES'
20535 !      include 'COMMON.IOUNITS'
20536 !      include 'COMMON.FFIELD'
20537 !      include 'COMMON.TORCNSTR'
20538 !      include 'COMMON.CONTROL'
20539       real(kind=8) :: etors_nucl,edihcnstr
20540       logical :: lprn
20541 !el local variables
20542       integer :: i,j,iblock,itori,itori1
20543       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
20544                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
20545 ! Set lprn=.true. for debugging
20546       lprn=.false.
20547 !     lprn=.true.
20548       etors_nucl=0.0D0
20549 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
20550       do i=iphi_nucl_start,iphi_nucl_end
20551         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
20552              .or. itype(i-3,2).eq.ntyp1_molec(2) &
20553              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
20554         etors_ii=0.0D0
20555         itori=itortyp_nucl(itype(i-2,2))
20556         itori1=itortyp_nucl(itype(i-1,2))
20557         phii=phi(i)
20558 !         print *,i,itori,itori1
20559         gloci=0.0D0
20560 !C Regular cosine and sine terms
20561         do j=1,nterm_nucl(itori,itori1)
20562           v1ij=v1_nucl(j,itori,itori1)
20563           v2ij=v2_nucl(j,itori,itori1)
20564           cosphi=dcos(j*phii)
20565           sinphi=dsin(j*phii)
20566           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
20567           if (energy_dec) etors_ii=etors_ii+&
20568                      v1ij*cosphi+v2ij*sinphi
20569           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
20570         enddo
20571 !C Lorentz terms
20572 !C                         v1
20573 !C  E = SUM ----------------------------------- - v1
20574 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
20575 !C
20576         cosphi=dcos(0.5d0*phii)
20577         sinphi=dsin(0.5d0*phii)
20578         do j=1,nlor_nucl(itori,itori1)
20579           vl1ij=vlor1_nucl(j,itori,itori1)
20580           vl2ij=vlor2_nucl(j,itori,itori1)
20581           vl3ij=vlor3_nucl(j,itori,itori1)
20582           pom=vl2ij*cosphi+vl3ij*sinphi
20583           pom1=1.0d0/(pom*pom+1.0d0)
20584           etors_nucl=etors_nucl+vl1ij*pom1
20585           if (energy_dec) etors_ii=etors_ii+ &
20586                      vl1ij*pom1
20587           pom=-pom*pom1*pom1
20588           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
20589         enddo
20590 !C Subtract the constant term
20591         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
20592           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
20593               'etor',i,etors_ii-v0_nucl(itori,itori1)
20594         if (lprn) &
20595        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
20596        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
20597        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
20598         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
20599 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
20600       enddo
20601       return
20602       end subroutine etor_nucl
20603 !------------------------------------------------------------
20604       subroutine epp_nucl_sub(evdw1,ees)
20605 !C
20606 !C This subroutine calculates the average interaction energy and its gradient
20607 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
20608 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
20609 !C The potential depends both on the distance of peptide-group centers and on
20610 !C the orientation of the CA-CA virtual bonds.
20611 !C
20612       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
20613       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
20614       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
20615                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
20616                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
20617       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20618                     dist_temp, dist_init,sss_grad,fac,evdw1ij
20619       integer xshift,yshift,zshift
20620       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
20621       real(kind=8) :: ees,eesij
20622 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20623       real(kind=8) scal_el /0.5d0/
20624       t_eelecij=0.0d0
20625       ees=0.0D0
20626       evdw1=0.0D0
20627       ind=0
20628 !c
20629 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
20630 !c
20631 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
20632       do i=iatel_s_nucl,iatel_e_nucl
20633         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20634         dxi=dc(1,i)
20635         dyi=dc(2,i)
20636         dzi=dc(3,i)
20637         dx_normi=dc_norm(1,i)
20638         dy_normi=dc_norm(2,i)
20639         dz_normi=dc_norm(3,i)
20640         xmedi=c(1,i)+0.5d0*dxi
20641         ymedi=c(2,i)+0.5d0*dyi
20642         zmedi=c(3,i)+0.5d0*dzi
20643           xmedi=dmod(xmedi,boxxsize)
20644           if (xmedi.lt.0) xmedi=xmedi+boxxsize
20645           ymedi=dmod(ymedi,boxysize)
20646           if (ymedi.lt.0) ymedi=ymedi+boxysize
20647           zmedi=dmod(zmedi,boxzsize)
20648           if (zmedi.lt.0) zmedi=zmedi+boxzsize
20649
20650         do j=ielstart_nucl(i),ielend_nucl(i)
20651           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
20652           ind=ind+1
20653           dxj=dc(1,j)
20654           dyj=dc(2,j)
20655           dzj=dc(3,j)
20656 !          xj=c(1,j)+0.5D0*dxj-xmedi
20657 !          yj=c(2,j)+0.5D0*dyj-ymedi
20658 !          zj=c(3,j)+0.5D0*dzj-zmedi
20659           xj=c(1,j)+0.5D0*dxj
20660           yj=c(2,j)+0.5D0*dyj
20661           zj=c(3,j)+0.5D0*dzj
20662           xj=mod(xj,boxxsize)
20663           if (xj.lt.0) xj=xj+boxxsize
20664           yj=mod(yj,boxysize)
20665           if (yj.lt.0) yj=yj+boxysize
20666           zj=mod(zj,boxzsize)
20667           if (zj.lt.0) zj=zj+boxzsize
20668       isubchap=0
20669       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20670       xj_safe=xj
20671       yj_safe=yj
20672       zj_safe=zj
20673       do xshift=-1,1
20674       do yshift=-1,1
20675       do zshift=-1,1
20676           xj=xj_safe+xshift*boxxsize
20677           yj=yj_safe+yshift*boxysize
20678           zj=zj_safe+zshift*boxzsize
20679           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20680           if(dist_temp.lt.dist_init) then
20681             dist_init=dist_temp
20682             xj_temp=xj
20683             yj_temp=yj
20684             zj_temp=zj
20685             isubchap=1
20686           endif
20687        enddo
20688        enddo
20689        enddo
20690        if (isubchap.eq.1) then
20691 !C          print *,i,j
20692           xj=xj_temp-xmedi
20693           yj=yj_temp-ymedi
20694           zj=zj_temp-zmedi
20695        else
20696           xj=xj_safe-xmedi
20697           yj=yj_safe-ymedi
20698           zj=zj_safe-zmedi
20699        endif
20700
20701           rij=xj*xj+yj*yj+zj*zj
20702 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
20703           fac=(r0pp**2/rij)**3
20704           ev1=epspp*fac*fac
20705           ev2=epspp*fac
20706           evdw1ij=ev1-2*ev2
20707           fac=(-ev1-evdw1ij)/rij
20708 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
20709           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
20710           evdw1=evdw1+evdw1ij
20711 !C
20712 !C Calculate contributions to the Cartesian gradient.
20713 !C
20714           ggg(1)=fac*xj
20715           ggg(2)=fac*yj
20716           ggg(3)=fac*zj
20717           do k=1,3
20718             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
20719             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
20720           enddo
20721 !c phoshate-phosphate electrostatic interactions
20722           rij=dsqrt(rij)
20723           fac=1.0d0/rij
20724           eesij=dexp(-BEES*rij)*fac
20725 !          write (2,*)"fac",fac," eesijpp",eesij
20726           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
20727           ees=ees+eesij
20728 !c          fac=-eesij*fac
20729           fac=-(fac+BEES)*eesij*fac
20730           ggg(1)=fac*xj
20731           ggg(2)=fac*yj
20732           ggg(3)=fac*zj
20733 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
20734 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
20735 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
20736           do k=1,3
20737             gelpp(k,i)=gelpp(k,i)-ggg(k)
20738             gelpp(k,j)=gelpp(k,j)+ggg(k)
20739           enddo
20740         enddo ! j
20741       enddo   ! i
20742 !c      ees=332.0d0*ees
20743       ees=AEES*ees
20744       do i=nnt,nct
20745 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20746         do k=1,3
20747           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
20748 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
20749           gelpp(k,i)=AEES*gelpp(k,i)
20750         enddo
20751 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20752       enddo
20753 !c      write (2,*) "total EES",ees
20754       return
20755       end subroutine epp_nucl_sub
20756 !---------------------------------------------------------------------
20757       subroutine epsb(evdwpsb,eelpsb)
20758 !      use comm_locel
20759 !C
20760 !C This subroutine calculates the excluded-volume interaction energy between
20761 !C peptide-group centers and side chains and its gradient in virtual-bond and
20762 !C side-chain vectors.
20763 !C
20764       real(kind=8),dimension(3):: ggg
20765       integer :: i,iint,j,k,iteli,itypj,subchap
20766       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
20767                    e1,e2,evdwij,rij,evdwpsb,eelpsb
20768       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20769                     dist_temp, dist_init
20770       integer xshift,yshift,zshift
20771
20772 !cd    print '(a)','Enter ESCP'
20773 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
20774       eelpsb=0.0d0
20775       evdwpsb=0.0d0
20776 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
20777       do i=iatscp_s_nucl,iatscp_e_nucl
20778         if (itype(i,2).eq.ntyp1_molec(2) &
20779          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20780         xi=0.5D0*(c(1,i)+c(1,i+1))
20781         yi=0.5D0*(c(2,i)+c(2,i+1))
20782         zi=0.5D0*(c(3,i)+c(3,i+1))
20783           xi=mod(xi,boxxsize)
20784           if (xi.lt.0) xi=xi+boxxsize
20785           yi=mod(yi,boxysize)
20786           if (yi.lt.0) yi=yi+boxysize
20787           zi=mod(zi,boxzsize)
20788           if (zi.lt.0) zi=zi+boxzsize
20789
20790         do iint=1,nscp_gr_nucl(i)
20791
20792         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
20793           itypj=itype(j,2)
20794           if (itypj.eq.ntyp1_molec(2)) cycle
20795 !C Uncomment following three lines for SC-p interactions
20796 !c         xj=c(1,nres+j)-xi
20797 !c         yj=c(2,nres+j)-yi
20798 !c         zj=c(3,nres+j)-zi
20799 !C Uncomment following three lines for Ca-p interactions
20800 !          xj=c(1,j)-xi
20801 !          yj=c(2,j)-yi
20802 !          zj=c(3,j)-zi
20803           xj=c(1,j)
20804           yj=c(2,j)
20805           zj=c(3,j)
20806           xj=mod(xj,boxxsize)
20807           if (xj.lt.0) xj=xj+boxxsize
20808           yj=mod(yj,boxysize)
20809           if (yj.lt.0) yj=yj+boxysize
20810           zj=mod(zj,boxzsize)
20811           if (zj.lt.0) zj=zj+boxzsize
20812       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20813       xj_safe=xj
20814       yj_safe=yj
20815       zj_safe=zj
20816       subchap=0
20817       do xshift=-1,1
20818       do yshift=-1,1
20819       do zshift=-1,1
20820           xj=xj_safe+xshift*boxxsize
20821           yj=yj_safe+yshift*boxysize
20822           zj=zj_safe+zshift*boxzsize
20823           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20824           if(dist_temp.lt.dist_init) then
20825             dist_init=dist_temp
20826             xj_temp=xj
20827             yj_temp=yj
20828             zj_temp=zj
20829             subchap=1
20830           endif
20831        enddo
20832        enddo
20833        enddo
20834        if (subchap.eq.1) then
20835           xj=xj_temp-xi
20836           yj=yj_temp-yi
20837           zj=zj_temp-zi
20838        else
20839           xj=xj_safe-xi
20840           yj=yj_safe-yi
20841           zj=zj_safe-zi
20842        endif
20843
20844           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20845           fac=rrij**expon2
20846           e1=fac*fac*aad_nucl(itypj)
20847           e2=fac*bad_nucl(itypj)
20848           if (iabs(j-i) .le. 2) then
20849             e1=scal14*e1
20850             e2=scal14*e2
20851           endif
20852           evdwij=e1+e2
20853           evdwpsb=evdwpsb+evdwij
20854           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
20855              'evdw2',i,j,evdwij,"tu4"
20856 !C
20857 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
20858 !C
20859           fac=-(evdwij+e1)*rrij
20860           ggg(1)=xj*fac
20861           ggg(2)=yj*fac
20862           ggg(3)=zj*fac
20863           do k=1,3
20864             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
20865             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
20866           enddo
20867         enddo
20868
20869         enddo ! iint
20870       enddo ! i
20871       do i=1,nct
20872         do j=1,3
20873           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
20874           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
20875         enddo
20876       enddo
20877       return
20878       end subroutine epsb
20879
20880 !------------------------------------------------------
20881       subroutine esb_gb(evdwsb,eelsb)
20882       use comm_locel
20883       use calc_data_nucl
20884       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
20885       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
20886       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
20887       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20888                     dist_temp, dist_init,aa,bb,faclip,sig0ij
20889       integer :: ii
20890       logical lprn
20891       evdw=0.0D0
20892       eelsb=0.0d0
20893       ecorr=0.0d0
20894       evdwsb=0.0D0
20895       lprn=.false.
20896       ind=0
20897 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
20898       do i=iatsc_s_nucl,iatsc_e_nucl
20899         num_conti=0
20900         num_conti2=0
20901         itypi=itype(i,2)
20902 !        PRINT *,"I=",i,itypi
20903         if (itypi.eq.ntyp1_molec(2)) cycle
20904         itypi1=itype(i+1,2)
20905         xi=c(1,nres+i)
20906         yi=c(2,nres+i)
20907         zi=c(3,nres+i)
20908           xi=dmod(xi,boxxsize)
20909           if (xi.lt.0) xi=xi+boxxsize
20910           yi=dmod(yi,boxysize)
20911           if (yi.lt.0) yi=yi+boxysize
20912           zi=dmod(zi,boxzsize)
20913           if (zi.lt.0) zi=zi+boxzsize
20914
20915         dxi=dc_norm(1,nres+i)
20916         dyi=dc_norm(2,nres+i)
20917         dzi=dc_norm(3,nres+i)
20918         dsci_inv=vbld_inv(i+nres)
20919 !C
20920 !C Calculate SC interaction energy.
20921 !C
20922         do iint=1,nint_gr_nucl(i)
20923 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
20924           do j=istart_nucl(i,iint),iend_nucl(i,iint)
20925             ind=ind+1
20926 !            print *,"JESTEM"
20927             itypj=itype(j,2)
20928             if (itypj.eq.ntyp1_molec(2)) cycle
20929             dscj_inv=vbld_inv(j+nres)
20930             sig0ij=sigma_nucl(itypi,itypj)
20931             chi1=chi_nucl(itypi,itypj)
20932             chi2=chi_nucl(itypj,itypi)
20933             chi12=chi1*chi2
20934             chip1=chip_nucl(itypi,itypj)
20935             chip2=chip_nucl(itypj,itypi)
20936             chip12=chip1*chip2
20937 !            xj=c(1,nres+j)-xi
20938 !            yj=c(2,nres+j)-yi
20939 !            zj=c(3,nres+j)-zi
20940            xj=c(1,nres+j)
20941            yj=c(2,nres+j)
20942            zj=c(3,nres+j)
20943           xj=dmod(xj,boxxsize)
20944           if (xj.lt.0) xj=xj+boxxsize
20945           yj=dmod(yj,boxysize)
20946           if (yj.lt.0) yj=yj+boxysize
20947           zj=dmod(zj,boxzsize)
20948           if (zj.lt.0) zj=zj+boxzsize
20949       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20950       xj_safe=xj
20951       yj_safe=yj
20952       zj_safe=zj
20953       subchap=0
20954       do xshift=-1,1
20955       do yshift=-1,1
20956       do zshift=-1,1
20957           xj=xj_safe+xshift*boxxsize
20958           yj=yj_safe+yshift*boxysize
20959           zj=zj_safe+zshift*boxzsize
20960           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20961           if(dist_temp.lt.dist_init) then
20962             dist_init=dist_temp
20963             xj_temp=xj
20964             yj_temp=yj
20965             zj_temp=zj
20966             subchap=1
20967           endif
20968        enddo
20969        enddo
20970        enddo
20971        if (subchap.eq.1) then
20972           xj=xj_temp-xi
20973           yj=yj_temp-yi
20974           zj=zj_temp-zi
20975        else
20976           xj=xj_safe-xi
20977           yj=yj_safe-yi
20978           zj=zj_safe-zi
20979        endif
20980
20981             dxj=dc_norm(1,nres+j)
20982             dyj=dc_norm(2,nres+j)
20983             dzj=dc_norm(3,nres+j)
20984             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20985             rij=dsqrt(rrij)
20986 !C Calculate angle-dependent terms of energy and contributions to their
20987 !C derivatives.
20988             erij(1)=xj*rij
20989             erij(2)=yj*rij
20990             erij(3)=zj*rij
20991             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
20992             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
20993             om12=dxi*dxj+dyi*dyj+dzi*dzj
20994             call sc_angular_nucl
20995             sigsq=1.0D0/sigsq
20996             sig=sig0ij*dsqrt(sigsq)
20997             rij_shift=1.0D0/rij-sig+sig0ij
20998 !            print *,rij_shift,"rij_shift"
20999 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
21000 !c     &       " rij_shift",rij_shift
21001             if (rij_shift.le.0.0D0) then
21002               evdw=1.0D20
21003               return
21004             endif
21005             sigder=-sig*sigsq
21006 !c---------------------------------------------------------------
21007             rij_shift=1.0D0/rij_shift
21008             fac=rij_shift**expon
21009             e1=fac*fac*aa_nucl(itypi,itypj)
21010             e2=fac*bb_nucl(itypi,itypj)
21011             evdwij=eps1*eps2rt*(e1+e2)
21012 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
21013 !c     &       " e1",e1," e2",e2," evdwij",evdwij
21014             eps2der=evdwij
21015             evdwij=evdwij*eps2rt
21016             evdwsb=evdwsb+evdwij
21017             if (lprn) then
21018             sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
21019             epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
21020             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
21021              restyp(itypi,2),i,restyp(itypj,2),j, &
21022              epsi,sigm,chi1,chi2,chip1,chip2, &
21023              eps1,eps2rt**2,sig,sig0ij, &
21024              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
21025             evdwij
21026             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
21027             endif
21028
21029             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
21030                              'evdw',i,j,evdwij,"tu3"
21031
21032
21033 !C Calculate gradient components.
21034             e1=e1*eps1*eps2rt**2
21035             fac=-expon*(e1+evdwij)*rij_shift
21036             sigder=fac*sigder
21037             fac=rij*fac
21038 !c            fac=0.0d0
21039 !C Calculate the radial part of the gradient
21040             gg(1)=xj*fac
21041             gg(2)=yj*fac
21042             gg(3)=zj*fac
21043 !C Calculate angular part of the gradient.
21044             call sc_grad_nucl
21045             call eelsbij(eelij,num_conti2)
21046             if (energy_dec .and. &
21047            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
21048           write (istat,'(e14.5)') evdwij
21049             eelsb=eelsb+eelij
21050           enddo      ! j
21051         enddo        ! iint
21052         num_cont_hb(i)=num_conti2
21053       enddo          ! i
21054 !c      write (iout,*) "Number of loop steps in EGB:",ind
21055 !cccc      energy_dec=.false.
21056       return
21057       end subroutine esb_gb
21058 !-------------------------------------------------------------------------------
21059       subroutine eelsbij(eesij,num_conti2)
21060       use comm_locel
21061       use calc_data_nucl
21062       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
21063       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
21064       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
21065                     dist_temp, dist_init,rlocshield,fracinbuf
21066       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
21067
21068 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
21069       real(kind=8) scal_el /0.5d0/
21070       integer :: iteli,itelj,kkk,kkll,m,isubchap
21071       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
21072       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
21073       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
21074                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
21075                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
21076                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
21077                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
21078                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
21079                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
21080                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
21081       ind=ind+1
21082       itypi=itype(i,2)
21083       itypj=itype(j,2)
21084 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
21085       ael6i=ael6_nucl(itypi,itypj)
21086       ael3i=ael3_nucl(itypi,itypj)
21087       ael63i=ael63_nucl(itypi,itypj)
21088       ael32i=ael32_nucl(itypi,itypj)
21089 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
21090 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
21091       dxj=dc(1,j+nres)
21092       dyj=dc(2,j+nres)
21093       dzj=dc(3,j+nres)
21094       dx_normi=dc_norm(1,i+nres)
21095       dy_normi=dc_norm(2,i+nres)
21096       dz_normi=dc_norm(3,i+nres)
21097       dx_normj=dc_norm(1,j+nres)
21098       dy_normj=dc_norm(2,j+nres)
21099       dz_normj=dc_norm(3,j+nres)
21100 !c      xj=c(1,j)+0.5D0*dxj-xmedi
21101 !c      yj=c(2,j)+0.5D0*dyj-ymedi
21102 !c      zj=c(3,j)+0.5D0*dzj-zmedi
21103       if (ipot_nucl.ne.2) then
21104         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
21105         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
21106         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
21107       else
21108         cosa=om12
21109         cosb=om1
21110         cosg=om2
21111       endif
21112       r3ij=rij*rrij
21113       r6ij=r3ij*r3ij
21114       fac=cosa-3.0D0*cosb*cosg
21115       facfac=fac*fac
21116       fac1=3.0d0*(cosb*cosb+cosg*cosg)
21117       fac3=ael6i*r6ij
21118       fac4=ael3i*r3ij
21119       fac5=ael63i*r6ij
21120       fac6=ael32i*r6ij
21121 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
21122 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
21123       el1=fac3*(4.0D0+facfac-fac1)
21124       el2=fac4*fac
21125       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
21126       el4=fac6*facfac
21127       eesij=el1+el2+el3+el4
21128 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
21129       ees0ij=4.0D0+facfac-fac1
21130
21131       if (energy_dec) then
21132           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
21133           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
21134            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
21135            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
21136            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
21137           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
21138       endif
21139
21140 !C
21141 !C Calculate contributions to the Cartesian gradient.
21142 !C
21143       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
21144       fac1=fac
21145 !c      erij(1)=xj*rmij
21146 !c      erij(2)=yj*rmij
21147 !c      erij(3)=zj*rmij
21148 !*
21149 !* Radial derivatives. First process both termini of the fragment (i,j)
21150 !*
21151       ggg(1)=facel*xj
21152       ggg(2)=facel*yj
21153       ggg(3)=facel*zj
21154       do k=1,3
21155         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21156         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21157         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
21158         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
21159       enddo
21160 !*
21161 !* Angular part
21162 !*
21163       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
21164       fac4=-3.0D0*fac4
21165       fac3=-6.0D0*fac3
21166       fac5= 6.0d0*fac5
21167       fac6=-6.0d0*fac6
21168       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
21169        fac6*fac1*cosg
21170       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
21171        fac6*fac1*cosb
21172       do k=1,3
21173         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
21174         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
21175       enddo
21176       do k=1,3
21177         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
21178       enddo
21179       do k=1,3
21180         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
21181              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
21182              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21183         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
21184              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21185              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21186         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21187         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21188       enddo
21189 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
21190        IF ( j.gt.i+1 .and.&
21191           num_conti.le.maxconts) THEN
21192 !C
21193 !C Calculate the contact function. The ith column of the array JCONT will
21194 !C contain the numbers of atoms that make contacts with the atom I (of numbers
21195 !C greater than I). The arrays FACONT and GACONT will contain the values of
21196 !C the contact function and its derivative.
21197         r0ij=2.20D0*sigma(itypi,itypj)
21198 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
21199         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
21200 !c        write (2,*) "fcont",fcont
21201         if (fcont.gt.0.0D0) then
21202           num_conti=num_conti+1
21203           num_conti2=num_conti2+1
21204
21205           if (num_conti.gt.maxconts) then
21206             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
21207                           ' will skip next contacts for this conf.'
21208           else
21209             jcont_hb(num_conti,i)=j
21210 !c            write (iout,*) "num_conti",num_conti,
21211 !c     &        " jcont_hb",jcont_hb(num_conti,i)
21212 !C Calculate contact energies
21213             cosa4=4.0D0*cosa
21214             wij=cosa-3.0D0*cosb*cosg
21215             cosbg1=cosb+cosg
21216             cosbg2=cosb-cosg
21217             fac3=dsqrt(-ael6i)*r3ij
21218 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
21219             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
21220             if (ees0tmp.gt.0) then
21221               ees0pij=dsqrt(ees0tmp)
21222             else
21223               ees0pij=0
21224             endif
21225             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21226             if (ees0tmp.gt.0) then
21227               ees0mij=dsqrt(ees0tmp)
21228             else
21229               ees0mij=0
21230             endif
21231             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21232             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
21233 !c            write (iout,*) "i",i," j",j,
21234 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21235             ees0pij1=fac3/ees0pij
21236             ees0mij1=fac3/ees0mij
21237             fac3p=-3.0D0*fac3*rrij
21238             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21239             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21240             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21241             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21242             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21243             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21244             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21245             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21246             ecosap=ecosa1+ecosa2
21247             ecosbp=ecosb1+ecosb2
21248             ecosgp=ecosg1+ecosg2
21249             ecosam=ecosa1-ecosa2
21250             ecosbm=ecosb1-ecosb2
21251             ecosgm=ecosg1-ecosg2
21252 !C End diagnostics
21253             facont_hb(num_conti,i)=fcont
21254             fprimcont=fprimcont/rij
21255             do k=1,3
21256               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21257               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21258             enddo
21259             gggp(1)=gggp(1)+ees0pijp*xj
21260             gggp(2)=gggp(2)+ees0pijp*yj
21261             gggp(3)=gggp(3)+ees0pijp*zj
21262             gggm(1)=gggm(1)+ees0mijp*xj
21263             gggm(2)=gggm(2)+ees0mijp*yj
21264             gggm(3)=gggm(3)+ees0mijp*zj
21265 !C Derivatives due to the contact function
21266             gacont_hbr(1,num_conti,i)=fprimcont*xj
21267             gacont_hbr(2,num_conti,i)=fprimcont*yj
21268             gacont_hbr(3,num_conti,i)=fprimcont*zj
21269             do k=1,3
21270 !c
21271 !c Gradient of the correlation terms
21272 !c
21273               gacontp_hb1(k,num_conti,i)= &
21274              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21275             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21276               gacontp_hb2(k,num_conti,i)= &
21277              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21278             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21279               gacontp_hb3(k,num_conti,i)=gggp(k)
21280               gacontm_hb1(k,num_conti,i)= &
21281              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21282             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21283               gacontm_hb2(k,num_conti,i)= &
21284              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21285             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21286               gacontm_hb3(k,num_conti,i)=gggm(k)
21287             enddo
21288           endif
21289         endif
21290       ENDIF
21291       return
21292       end subroutine eelsbij
21293 !------------------------------------------------------------------
21294       subroutine sc_grad_nucl
21295       use comm_locel
21296       use calc_data_nucl
21297       real(kind=8),dimension(3) :: dcosom1,dcosom2
21298       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21299       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21300       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21301       do k=1,3
21302         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21303         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21304       enddo
21305       do k=1,3
21306         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21307       enddo
21308       do k=1,3
21309         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21310                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21311                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21312         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21313                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21314                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21315       enddo
21316 !C
21317 !C Calculate the components of the gradient in DC and X
21318 !C
21319       do l=1,3
21320         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21321         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21322       enddo
21323       return
21324       end subroutine sc_grad_nucl
21325 !-----------------------------------------------------------------------
21326       subroutine esb(esbloc)
21327 !C Calculate the local energy of a side chain and its derivatives in the
21328 !C corresponding virtual-bond valence angles THETA and the spherical angles
21329 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21330 !C added by Urszula Kozlowska. 07/11/2007
21331 !C
21332       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21333       real(kind=8),dimension(9):: x
21334      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21335       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21336       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21337       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21338        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21339        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21340        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21341        integer::it,nlobit,i,j,k
21342 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21343       delta=0.02d0*pi
21344       esbloc=0.0D0
21345       do i=loc_start_nucl,loc_end_nucl
21346         if (itype(i,2).eq.ntyp1_molec(2)) cycle
21347         costtab(i+1) =dcos(theta(i+1))
21348         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21349         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21350         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21351         cosfac2=0.5d0/(1.0d0+costtab(i+1))
21352         cosfac=dsqrt(cosfac2)
21353         sinfac2=0.5d0/(1.0d0-costtab(i+1))
21354         sinfac=dsqrt(sinfac2)
21355         it=itype(i,2)
21356         if (it.eq.10) goto 1
21357
21358 !c
21359 !C  Compute the axes of tghe local cartesian coordinates system; store in
21360 !c   x_prime, y_prime and z_prime
21361 !c
21362         do j=1,3
21363           x_prime(j) = 0.00
21364           y_prime(j) = 0.00
21365           z_prime(j) = 0.00
21366         enddo
21367 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21368 !C     &   dc_norm(3,i+nres)
21369         do j = 1,3
21370           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21371           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21372         enddo
21373         do j = 1,3
21374           z_prime(j) = -uz(j,i-1)
21375 !           z_prime(j)=0.0
21376         enddo
21377
21378         xx=0.0d0
21379         yy=0.0d0
21380         zz=0.0d0
21381         do j = 1,3
21382           xx = xx + x_prime(j)*dc_norm(j,i+nres)
21383           yy = yy + y_prime(j)*dc_norm(j,i+nres)
21384           zz = zz + z_prime(j)*dc_norm(j,i+nres)
21385         enddo
21386
21387         xxtab(i)=xx
21388         yytab(i)=yy
21389         zztab(i)=zz
21390          it=itype(i,2)
21391         do j = 1,9
21392           x(j) = sc_parmin_nucl(j,it)
21393         enddo
21394 #ifdef CHECK_COORD
21395 !Cc diagnostics - remove later
21396         xx1 = dcos(alph(2))
21397         yy1 = dsin(alph(2))*dcos(omeg(2))
21398         zz1 = -dsin(alph(2))*dsin(omeg(2))
21399         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21400          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21401          xx1,yy1,zz1
21402 !C,"  --- ", xx_w,yy_w,zz_w
21403 !c end diagnostics
21404 #endif
21405         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21406         esbloc = esbloc + sumene
21407         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21408 !        print *,"enecomp",sumene,sumene2
21409 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21410 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21411 #ifdef DEBUG
21412         write (2,*) "x",(x(k),k=1,9)
21413 !C
21414 !C This section to check the numerical derivatives of the energy of ith side
21415 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
21416 !C #define DEBUG in the code to turn it on.
21417 !C
21418         write (2,*) "sumene               =",sumene
21419         aincr=1.0d-7
21420         xxsave=xx
21421         xx=xx+aincr
21422         write (2,*) xx,yy,zz
21423         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21424         de_dxx_num=(sumenep-sumene)/aincr
21425         xx=xxsave
21426         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
21427         yysave=yy
21428         yy=yy+aincr
21429         write (2,*) xx,yy,zz
21430         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21431         de_dyy_num=(sumenep-sumene)/aincr
21432         yy=yysave
21433         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
21434         zzsave=zz
21435         zz=zz+aincr
21436         write (2,*) xx,yy,zz
21437         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21438         de_dzz_num=(sumenep-sumene)/aincr
21439         zz=zzsave
21440         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
21441         costsave=cost2tab(i+1)
21442         sintsave=sint2tab(i+1)
21443         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
21444         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
21445         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21446         de_dt_num=(sumenep-sumene)/aincr
21447         write (2,*) " t+ sumene from enesc=",sumenep,sumene
21448         cost2tab(i+1)=costsave
21449         sint2tab(i+1)=sintsave
21450 !C End of diagnostics section.
21451 #endif
21452 !C
21453 !C Compute the gradient of esc
21454 !C
21455         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
21456         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
21457         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
21458         de_dtt=0.0d0
21459 #ifdef DEBUG
21460         write (2,*) "x",(x(k),k=1,9)
21461         write (2,*) "xx",xx," yy",yy," zz",zz
21462         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
21463           " de_zz   ",de_zz," de_tt   ",de_tt
21464         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
21465           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
21466 #endif
21467 !C
21468        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
21469        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
21470        cosfac2xx=cosfac2*xx
21471        sinfac2yy=sinfac2*yy
21472        do k = 1,3
21473          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
21474            vbld_inv(i+1)
21475          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
21476            vbld_inv(i)
21477          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
21478          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
21479 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
21480 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
21481 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
21482 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
21483          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
21484          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
21485          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
21486          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
21487          dZZ_Ci1(k)=0.0d0
21488          dZZ_Ci(k)=0.0d0
21489          do j=1,3
21490            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
21491            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
21492          enddo
21493
21494          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
21495          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
21496          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
21497 !c
21498          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
21499          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
21500        enddo
21501
21502        do k=1,3
21503          dXX_Ctab(k,i)=dXX_Ci(k)
21504          dXX_C1tab(k,i)=dXX_Ci1(k)
21505          dYY_Ctab(k,i)=dYY_Ci(k)
21506          dYY_C1tab(k,i)=dYY_Ci1(k)
21507          dZZ_Ctab(k,i)=dZZ_Ci(k)
21508          dZZ_C1tab(k,i)=dZZ_Ci1(k)
21509          dXX_XYZtab(k,i)=dXX_XYZ(k)
21510          dYY_XYZtab(k,i)=dYY_XYZ(k)
21511          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
21512        enddo
21513        do k = 1,3
21514 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
21515 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
21516 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
21517 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
21518 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
21519 !c     &    dt_dci(k)
21520 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
21521 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
21522          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
21523          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
21524          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
21525          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
21526          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
21527          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
21528 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
21529        enddo
21530 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
21531 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
21532
21533 !C to check gradient call subroutine check_grad
21534
21535     1 continue
21536       enddo
21537       return
21538       end subroutine esb
21539 !=-------------------------------------------------------
21540       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
21541 !      implicit none
21542       real(kind=8),dimension(9):: x(9)
21543        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
21544       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
21545       integer i
21546 !c      write (2,*) "enesc"
21547 !c      write (2,*) "x",(x(i),i=1,9)
21548 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
21549       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
21550         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
21551         + x(9)*yy*zz
21552       enesc_nucl=sumene
21553       return
21554       end function enesc_nucl
21555 !-----------------------------------------------------------------------------
21556       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
21557 #ifdef MPI
21558       include 'mpif.h'
21559       integer,parameter :: max_cont=2000
21560       integer,parameter:: max_dim=2*(8*3+6)
21561       integer, parameter :: msglen1=max_cont*max_dim
21562       integer,parameter :: msglen2=2*msglen1
21563       integer source,CorrelType,CorrelID,Error
21564       real(kind=8) :: buffer(max_cont,max_dim)
21565       integer status(MPI_STATUS_SIZE)
21566       integer :: ierror,nbytes
21567 #endif
21568       real(kind=8),dimension(3):: gx(3),gx1(3)
21569       real(kind=8) :: time00
21570       logical lprn,ldone
21571       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
21572       real(kind=8) ecorr,ecorr3
21573       integer :: n_corr,n_corr1,mm,msglen
21574 !C Set lprn=.true. for debugging
21575       lprn=.false.
21576       n_corr=0
21577       n_corr1=0
21578 #ifdef MPI
21579       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
21580
21581       if (nfgtasks.le.1) goto 30
21582       if (lprn) then
21583         write (iout,'(a)') 'Contact function values:'
21584         do i=nnt,nct-1
21585           write (iout,'(2i3,50(1x,i2,f5.2))')  &
21586          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21587          j=1,num_cont_hb(i))
21588         enddo
21589       endif
21590 !C Caution! Following code assumes that electrostatic interactions concerning
21591 !C a given atom are split among at most two processors!
21592       CorrelType=477
21593       CorrelID=fg_rank+1
21594       ldone=.false.
21595       do i=1,max_cont
21596         do j=1,max_dim
21597           buffer(i,j)=0.0D0
21598         enddo
21599       enddo
21600       mm=mod(fg_rank,2)
21601 !c      write (*,*) 'MyRank',MyRank,' mm',mm
21602       if (mm) 20,20,10
21603    10 continue
21604 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
21605       if (fg_rank.gt.0) then
21606 !C Send correlation contributions to the preceding processor
21607         msglen=msglen1
21608         nn=num_cont_hb(iatel_s_nucl)
21609         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
21610 !c        write (*,*) 'The BUFFER array:'
21611 !c        do i=1,nn
21612 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
21613 !c        enddo
21614         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
21615           msglen=msglen2
21616           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
21617 !C Clear the contacts of the atom passed to the neighboring processor
21618         nn=num_cont_hb(iatel_s_nucl+1)
21619 !c        do i=1,nn
21620 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
21621 !c        enddo
21622             num_cont_hb(iatel_s_nucl)=0
21623         endif
21624 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
21625 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
21626 !cd   & ' msglen=',msglen
21627 !c        write (*,*) 'Processor ',fg_rank,MyRank,
21628 !c     & ' is sending correlation contribution to processor',fg_rank-1,
21629 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21630         time00=MPI_Wtime()
21631         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
21632          CorrelType,FG_COMM,IERROR)
21633         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21634 !cd      write (iout,*) 'Processor ',fg_rank,
21635 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
21636 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
21637 !c        write (*,*) 'Processor ',fg_rank,
21638 !c     & ' has sent correlation contribution to processor',fg_rank-1,
21639 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
21640 !c        msglen=msglen1
21641       endif ! (fg_rank.gt.0)
21642       if (ldone) goto 30
21643       ldone=.true.
21644    20 continue
21645 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
21646       if (fg_rank.lt.nfgtasks-1) then
21647 !C Receive correlation contributions from the next processor
21648         msglen=msglen1
21649         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
21650 !cd      write (iout,*) 'Processor',fg_rank,
21651 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
21652 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
21653 !c        write (*,*) 'Processor',fg_rank,
21654 !c     &' is receiving correlation contribution from processor',fg_rank+1,
21655 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21656         time00=MPI_Wtime()
21657         nbytes=-1
21658         do while (nbytes.le.0)
21659           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21660           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
21661         enddo
21662 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
21663         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
21664          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21665         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21666 !c        write (*,*) 'Processor',fg_rank,
21667 !c     &' has received correlation contribution from processor',fg_rank+1,
21668 !c     & ' msglen=',msglen,' nbytes=',nbytes
21669 !c        write (*,*) 'The received BUFFER array:'
21670 !c        do i=1,max_cont
21671 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
21672 !c        enddo
21673         if (msglen.eq.msglen1) then
21674           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
21675         else if (msglen.eq.msglen2)  then
21676           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
21677           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
21678         else
21679           write (iout,*) &
21680       'ERROR!!!! message length changed while processing correlations.'
21681           write (*,*) &
21682       'ERROR!!!! message length changed while processing correlations.'
21683           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
21684         endif ! msglen.eq.msglen1
21685       endif ! fg_rank.lt.nfgtasks-1
21686       if (ldone) goto 30
21687       ldone=.true.
21688       goto 10
21689    30 continue
21690 #endif
21691       if (lprn) then
21692         write (iout,'(a)') 'Contact function values:'
21693         do i=nnt_molec(2),nct_molec(2)-1
21694           write (iout,'(2i3,50(1x,i2,f5.2))') &
21695          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21696          j=1,num_cont_hb(i))
21697         enddo
21698       endif
21699       ecorr=0.0D0
21700       ecorr3=0.0d0
21701 !C Remove the loop below after debugging !!!
21702 !      do i=nnt_molec(2),nct_molec(2)
21703 !        do j=1,3
21704 !          gradcorr_nucl(j,i)=0.0D0
21705 !          gradxorr_nucl(j,i)=0.0D0
21706 !          gradcorr3_nucl(j,i)=0.0D0
21707 !          gradxorr3_nucl(j,i)=0.0D0
21708 !        enddo
21709 !      enddo
21710 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
21711 !C Calculate the local-electrostatic correlation terms
21712       do i=iatsc_s_nucl,iatsc_e_nucl
21713         i1=i+1
21714         num_conti=num_cont_hb(i)
21715         num_conti1=num_cont_hb(i+1)
21716 !        print *,i,num_conti,num_conti1
21717         do jj=1,num_conti
21718           j=jcont_hb(jj,i)
21719           do kk=1,num_conti1
21720             j1=jcont_hb(kk,i1)
21721 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
21722 !c     &         ' jj=',jj,' kk=',kk
21723             if (j1.eq.j+1 .or. j1.eq.j-1) then
21724 !C
21725 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
21726 !C The system gains extra energy.
21727 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
21728 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21729 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
21730 !C
21731               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21732               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
21733                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21734               n_corr=n_corr+1
21735             else if (j1.eq.j) then
21736 !C
21737 !C Contacts I-J and I-(J+1) occur simultaneously.
21738 !C The system loses extra energy.
21739 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
21740 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21741 !C Need to implement full formulas 32 from Liwo et al., 1998.
21742 !C
21743 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21744 !c     &         ' jj=',jj,' kk=',kk
21745               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
21746             endif
21747           enddo ! kk
21748           do kk=1,num_conti
21749             j1=jcont_hb(kk,i)
21750 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21751 !c     &         ' jj=',jj,' kk=',kk
21752             if (j1.eq.j+1) then
21753 !C Contacts I-J and (I+1)-J occur simultaneously.
21754 !C The system loses extra energy.
21755               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
21756             endif ! j1==j+1
21757           enddo ! kk
21758         enddo ! jj
21759       enddo ! i
21760       return
21761       end subroutine multibody_hb_nucl
21762 !-----------------------------------------------------------
21763       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21764 !      implicit real*8 (a-h,o-z)
21765 !      include 'DIMENSIONS'
21766 !      include 'COMMON.IOUNITS'
21767 !      include 'COMMON.DERIV'
21768 !      include 'COMMON.INTERACT'
21769 !      include 'COMMON.CONTACTS'
21770       real(kind=8),dimension(3) :: gx,gx1
21771       logical :: lprn
21772 !el local variables
21773       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21774       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21775                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21776                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21777                    rlocshield
21778
21779       lprn=.false.
21780       eij=facont_hb(jj,i)
21781       ekl=facont_hb(kk,k)
21782       ees0pij=ees0p(jj,i)
21783       ees0pkl=ees0p(kk,k)
21784       ees0mij=ees0m(jj,i)
21785       ees0mkl=ees0m(kk,k)
21786       ekont=eij*ekl
21787       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21788 !      print *,"ehbcorr_nucl",ekont,ees
21789 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21790 !C Following 4 lines for diagnostics.
21791 !cd    ees0pkl=0.0D0
21792 !cd    ees0pij=1.0D0
21793 !cd    ees0mkl=0.0D0
21794 !cd    ees0mij=1.0D0
21795 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21796 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21797 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21798 !C Calculate the multi-body contribution to energy.
21799 !      ecorr_nucl=ecorr_nucl+ekont*ees
21800 !C Calculate multi-body contributions to the gradient.
21801       coeffpees0pij=coeffp*ees0pij
21802       coeffmees0mij=coeffm*ees0mij
21803       coeffpees0pkl=coeffp*ees0pkl
21804       coeffmees0mkl=coeffm*ees0mkl
21805       do ll=1,3
21806         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
21807        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21808        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21809         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
21810         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
21811         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21812         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
21813         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
21814         coeffmees0mij*gacontm_hb1(ll,kk,k))
21815         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
21816         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21817         coeffmees0mij*gacontm_hb2(ll,kk,k))
21818         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21819           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21820           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21821         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
21822         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
21823         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21824           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21825           coeffmees0mij*gacontm_hb3(ll,kk,k))
21826         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
21827         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
21828         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
21829         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
21830         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
21831         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
21832       enddo
21833       ehbcorr_nucl=ekont*ees
21834       return
21835       end function ehbcorr_nucl
21836 !-------------------------------------------------------------------------
21837
21838      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21839 !      implicit real*8 (a-h,o-z)
21840 !      include 'DIMENSIONS'
21841 !      include 'COMMON.IOUNITS'
21842 !      include 'COMMON.DERIV'
21843 !      include 'COMMON.INTERACT'
21844 !      include 'COMMON.CONTACTS'
21845       real(kind=8),dimension(3) :: gx,gx1
21846       logical :: lprn
21847 !el local variables
21848       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21849       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21850                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21851                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21852                    rlocshield
21853
21854       lprn=.false.
21855       eij=facont_hb(jj,i)
21856       ekl=facont_hb(kk,k)
21857       ees0pij=ees0p(jj,i)
21858       ees0pkl=ees0p(kk,k)
21859       ees0mij=ees0m(jj,i)
21860       ees0mkl=ees0m(kk,k)
21861       ekont=eij*ekl
21862       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21863 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21864 !C Following 4 lines for diagnostics.
21865 !cd    ees0pkl=0.0D0
21866 !cd    ees0pij=1.0D0
21867 !cd    ees0mkl=0.0D0
21868 !cd    ees0mij=1.0D0
21869 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21870 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21871 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21872 !C Calculate the multi-body contribution to energy.
21873 !      ecorr=ecorr+ekont*ees
21874 !C Calculate multi-body contributions to the gradient.
21875       coeffpees0pij=coeffp*ees0pij
21876       coeffmees0mij=coeffm*ees0mij
21877       coeffpees0pkl=coeffp*ees0pkl
21878       coeffmees0mkl=coeffm*ees0mkl
21879       do ll=1,3
21880         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
21881        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21882        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21883         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
21884         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
21885         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21886         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
21887         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
21888         coeffmees0mij*gacontm_hb1(ll,kk,k))
21889         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
21890         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21891         coeffmees0mij*gacontm_hb2(ll,kk,k))
21892         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21893           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21894           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21895         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
21896         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
21897         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21898           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21899           coeffmees0mij*gacontm_hb3(ll,kk,k))
21900         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
21901         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
21902         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
21903         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
21904         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
21905         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
21906       enddo
21907       ehbcorr3_nucl=ekont*ees
21908       return
21909       end function ehbcorr3_nucl
21910 #ifdef MPI
21911       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
21912       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21913       real(kind=8):: buffer(dimen1,dimen2)
21914       num_kont=num_cont_hb(atom)
21915       do i=1,num_kont
21916         do k=1,8
21917           do j=1,3
21918             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
21919           enddo ! j
21920         enddo ! k
21921         buffer(i,indx+25)=facont_hb(i,atom)
21922         buffer(i,indx+26)=ees0p(i,atom)
21923         buffer(i,indx+27)=ees0m(i,atom)
21924         buffer(i,indx+28)=d_cont(i,atom)
21925         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
21926       enddo ! i
21927       buffer(1,indx+30)=dfloat(num_kont)
21928       return
21929       end subroutine pack_buffer
21930 !c------------------------------------------------------------------------------
21931       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
21932       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21933       real(kind=8):: buffer(dimen1,dimen2)
21934 !      double precision zapas
21935 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
21936 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
21937 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
21938 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
21939       num_kont=buffer(1,indx+30)
21940       num_kont_old=num_cont_hb(atom)
21941       num_cont_hb(atom)=num_kont+num_kont_old
21942       do i=1,num_kont
21943         ii=i+num_kont_old
21944         do k=1,8
21945           do j=1,3
21946             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
21947           enddo ! j
21948         enddo ! k
21949         facont_hb(ii,atom)=buffer(i,indx+25)
21950         ees0p(ii,atom)=buffer(i,indx+26)
21951         ees0m(ii,atom)=buffer(i,indx+27)
21952         d_cont(i,atom)=buffer(i,indx+28)
21953         jcont_hb(ii,atom)=buffer(i,indx+29)
21954       enddo ! i
21955       return
21956       end subroutine unpack_buffer
21957 !c------------------------------------------------------------------------------
21958 #endif
21959       subroutine ecatcat(ecationcation)
21960         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k
21961         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21962         r7,r4,ecationcation,k0,rcal
21963         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21964         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
21965         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21966         gg,r
21967
21968         ecationcation=0.0d0
21969         if (nres_molec(5).eq.0) return
21970         rcat0=3.472
21971         epscalc=0.05
21972         r06 = rcat0**6
21973         r012 = r06**2
21974         k0 = 332.0*(2.0*2.0)/80.0
21975         itmp=0
21976
21977         do i=1,4
21978         itmp=itmp+nres_molec(i)
21979         enddo
21980 !        write(iout,*) "itmp",itmp
21981         do i=itmp+1,itmp+nres_molec(5)-1
21982
21983         xi=c(1,i)
21984         yi=c(2,i)
21985         zi=c(3,i)
21986
21987           xi=mod(xi,boxxsize)
21988           if (xi.lt.0) xi=xi+boxxsize
21989           yi=mod(yi,boxysize)
21990           if (yi.lt.0) yi=yi+boxysize
21991           zi=mod(zi,boxzsize)
21992           if (zi.lt.0) zi=zi+boxzsize
21993
21994           do j=i+1,itmp+nres_molec(5)
21995 !           print *,i,j,'catcat'
21996            xj=c(1,j)
21997            yj=c(2,j)
21998            zj=c(3,j)
21999           xj=dmod(xj,boxxsize)
22000           if (xj.lt.0) xj=xj+boxxsize
22001           yj=dmod(yj,boxysize)
22002           if (yj.lt.0) yj=yj+boxysize
22003           zj=dmod(zj,boxzsize)
22004           if (zj.lt.0) zj=zj+boxzsize
22005 !          write(iout,*) c(1,i),xi,xj,"xy",boxxsize
22006       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22007       xj_safe=xj
22008       yj_safe=yj
22009       zj_safe=zj
22010       subchap=0
22011       do xshift=-1,1
22012       do yshift=-1,1
22013       do zshift=-1,1
22014           xj=xj_safe+xshift*boxxsize
22015           yj=yj_safe+yshift*boxysize
22016           zj=zj_safe+zshift*boxzsize
22017           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22018           if(dist_temp.lt.dist_init) then
22019             dist_init=dist_temp
22020             xj_temp=xj
22021             yj_temp=yj
22022             zj_temp=zj
22023             subchap=1
22024           endif
22025        enddo
22026        enddo
22027        enddo
22028        if (subchap.eq.1) then
22029           xj=xj_temp-xi
22030           yj=yj_temp-yi
22031           zj=zj_temp-zi
22032        else
22033           xj=xj_safe-xi
22034           yj=yj_safe-yi
22035           zj=zj_safe-zi
22036        endif
22037        rcal =xj**2+yj**2+zj**2
22038         ract=sqrt(rcal)
22039 !        rcat0=3.472
22040 !        epscalc=0.05
22041 !        r06 = rcat0**6
22042 !        r012 = r06**2
22043 !        k0 = 332*(2*2)/80
22044         Evan1cat=epscalc*(r012/rcal**6)
22045         Evan2cat=epscalc*2*(r06/rcal**3)
22046         Eeleccat=k0/ract
22047         r7 = rcal**7
22048         r4 = rcal**4
22049         r(1)=xj
22050         r(2)=yj
22051         r(3)=zj
22052         do k=1,3
22053           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
22054           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
22055           dEeleccat(k)=-k0*r(k)/ract**3
22056         enddo
22057         do k=1,3
22058           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
22059           gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
22060           gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
22061         enddo
22062
22063 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
22064         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
22065        enddo
22066        enddo
22067        return
22068        end subroutine ecatcat
22069 !---------------------------------------------------------------------------
22070        subroutine ecat_prot(ecation_prot)
22071        integer i,j,k,subchap,itmp,inum
22072         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
22073         r7,r4,ecationcation
22074         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
22075         dist_init,dist_temp,ecation_prot,rcal,rocal,   &
22076         Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
22077         catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
22078         wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
22079         costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
22080         Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
22081         rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
22082         opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
22083         opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
22084         Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip
22085         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
22086         gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
22087         dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
22088         tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
22089         v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
22090         dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
22091         dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
22092         dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
22093         dEvan1Cat
22094         real(kind=8),dimension(6) :: vcatprm
22095         ecation_prot=0.0d0
22096 ! first lets calculate interaction with peptide groups
22097         if (nres_molec(5).eq.0) return
22098          wconst=78
22099         wdip =1.092777950857032D2
22100         wdip=wdip/wconst
22101         wmodquad=-2.174122713004870D4
22102         wmodquad=wmodquad/wconst
22103         wquad1 = 3.901232068562804D1
22104         wquad1=wquad1/wconst
22105         wquad2 = 3
22106         wquad2=wquad2/wconst
22107         wvan1 = 0.1
22108         wvan2 = 6
22109         itmp=0
22110         do i=1,4
22111         itmp=itmp+nres_molec(i)
22112         enddo
22113 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
22114         do i=ibond_start,ibond_end
22115 !         cycle
22116          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
22117         xi=0.5d0*(c(1,i)+c(1,i+1))
22118         yi=0.5d0*(c(2,i)+c(2,i+1))
22119         zi=0.5d0*(c(3,i)+c(3,i+1))
22120           xi=mod(xi,boxxsize)
22121           if (xi.lt.0) xi=xi+boxxsize
22122           yi=mod(yi,boxysize)
22123           if (yi.lt.0) yi=yi+boxysize
22124           zi=mod(zi,boxzsize)
22125           if (zi.lt.0) zi=zi+boxzsize
22126
22127          do j=itmp+1,itmp+nres_molec(5)
22128            xj=c(1,j)
22129            yj=c(2,j)
22130            zj=c(3,j)
22131           xj=dmod(xj,boxxsize)
22132           if (xj.lt.0) xj=xj+boxxsize
22133           yj=dmod(yj,boxysize)
22134           if (yj.lt.0) yj=yj+boxysize
22135           zj=dmod(zj,boxzsize)
22136           if (zj.lt.0) zj=zj+boxzsize
22137       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22138       xj_safe=xj
22139       yj_safe=yj
22140       zj_safe=zj
22141       subchap=0
22142       do xshift=-1,1
22143       do yshift=-1,1
22144       do zshift=-1,1
22145           xj=xj_safe+xshift*boxxsize
22146           yj=yj_safe+yshift*boxysize
22147           zj=zj_safe+zshift*boxzsize
22148           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22149           if(dist_temp.lt.dist_init) then
22150             dist_init=dist_temp
22151             xj_temp=xj
22152             yj_temp=yj
22153             zj_temp=zj
22154             subchap=1
22155           endif
22156        enddo
22157        enddo
22158        enddo
22159        if (subchap.eq.1) then
22160           xj=xj_temp-xi
22161           yj=yj_temp-yi
22162           zj=zj_temp-zi
22163        else
22164           xj=xj_safe-xi
22165           yj=yj_safe-yi
22166           zj=zj_safe-zi
22167        endif
22168 !       enddo
22169 !       enddo
22170        rcpm = sqrt(xj**2+yj**2+zj**2)
22171        drcp_norm(1)=xj/rcpm
22172        drcp_norm(2)=yj/rcpm
22173        drcp_norm(3)=zj/rcpm
22174        dcmag=0.0
22175        do k=1,3
22176        dcmag=dcmag+dc(k,i)**2
22177        enddo
22178        dcmag=dsqrt(dcmag)
22179        do k=1,3
22180          myd_norm(k)=dc(k,i)/dcmag
22181        enddo
22182         costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
22183         drcp_norm(3)*myd_norm(3)
22184         rsecp = rcpm**2
22185         Ir = 1.0d0/rcpm
22186         Irsecp = 1.0d0/rsecp
22187         Irthrp = Irsecp/rcpm
22188         Irfourp = Irthrp/rcpm
22189         Irfiftp = Irfourp/rcpm
22190         Irsistp=Irfiftp/rcpm
22191         Irseven=Irsistp/rcpm
22192         Irtwelv=Irsistp*Irsistp
22193         Irthir=Irtwelv/rcpm
22194         sin2thet = (1-costhet*costhet)
22195         sinthet=sqrt(sin2thet)
22196         E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
22197              *sin2thet
22198         E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
22199              2*wvan2**6*Irsistp)
22200         ecation_prot = ecation_prot+E1+E2
22201         dE1dr = -2*costhet*wdip*Irthrp-&
22202          (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
22203         dE2dr = 3*wquad1*wquad2*Irfourp-     &
22204           12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
22205         dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
22206         do k=1,3
22207           drdpep(k) = -drcp_norm(k)
22208           dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
22209           dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
22210           dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
22211           dEddci(k) = dEdcos*dcosddci(k)
22212         enddo
22213         do k=1,3
22214         gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
22215         gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
22216         gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
22217         enddo
22218        enddo ! j
22219        enddo ! i
22220 !------------------------------------------sidechains
22221 !        do i=1,nres_molec(1)
22222         do i=ibond_start,ibond_end
22223          if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
22224 !         cycle
22225 !        print *,i,ecation_prot
22226         xi=(c(1,i+nres))
22227         yi=(c(2,i+nres))
22228         zi=(c(3,i+nres))
22229           xi=mod(xi,boxxsize)
22230           if (xi.lt.0) xi=xi+boxxsize
22231           yi=mod(yi,boxysize)
22232           if (yi.lt.0) yi=yi+boxysize
22233           zi=mod(zi,boxzsize)
22234           if (zi.lt.0) zi=zi+boxzsize
22235           do k=1,3
22236             cm1(k)=dc(k,i+nres)
22237           enddo
22238            cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
22239          do j=itmp+1,itmp+nres_molec(5)
22240            xj=c(1,j)
22241            yj=c(2,j)
22242            zj=c(3,j)
22243           xj=dmod(xj,boxxsize)
22244           if (xj.lt.0) xj=xj+boxxsize
22245           yj=dmod(yj,boxysize)
22246           if (yj.lt.0) yj=yj+boxysize
22247           zj=dmod(zj,boxzsize)
22248           if (zj.lt.0) zj=zj+boxzsize
22249       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22250       xj_safe=xj
22251       yj_safe=yj
22252       zj_safe=zj
22253       subchap=0
22254       do xshift=-1,1
22255       do yshift=-1,1
22256       do zshift=-1,1
22257           xj=xj_safe+xshift*boxxsize
22258           yj=yj_safe+yshift*boxysize
22259           zj=zj_safe+zshift*boxzsize
22260           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22261           if(dist_temp.lt.dist_init) then
22262             dist_init=dist_temp
22263             xj_temp=xj
22264             yj_temp=yj
22265             zj_temp=zj
22266             subchap=1
22267           endif
22268        enddo
22269        enddo
22270        enddo
22271        if (subchap.eq.1) then
22272           xj=xj_temp-xi
22273           yj=yj_temp-yi
22274           zj=zj_temp-zi
22275        else
22276           xj=xj_safe-xi
22277           yj=yj_safe-yi
22278           zj=zj_safe-zi
22279        endif
22280 !       enddo
22281 !       enddo
22282          if(itype(i,1).eq.15.or.itype(i,1).eq.16) then
22283             if(itype(i,1).eq.16) then
22284             inum=1
22285             else
22286             inum=2
22287             endif
22288             do k=1,6
22289             vcatprm(k)=catprm(k,inum)
22290             enddo
22291             dASGL=catprm(7,inum)
22292              do k=1,3
22293                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22294                 valpha(k)=c(k,i)
22295                 vcat(k)=c(k,j)
22296               enddo
22297                       do k=1,3
22298           dx(k) = vcat(k)-vcm(k)
22299         enddo
22300         do k=1,3
22301           v1(k)=(vcm(k)-valpha(k))
22302           v2(k)=(vcat(k)-valpha(k))
22303         enddo
22304         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22305         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22306         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22307
22308 !  The weights of the energy function calculated from
22309 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
22310         wh2o=78
22311         wc = vcatprm(1)
22312         wc=wc/wh2o
22313         wdip =vcatprm(2)
22314         wdip=wdip/wh2o
22315         wquad1 =vcatprm(3)
22316         wquad1=wquad1/wh2o
22317         wquad2 = vcatprm(4)
22318         wquad2=wquad2/wh2o
22319         wquad2p = 1-wquad2
22320         wvan1 = vcatprm(5)
22321         wvan2 =vcatprm(6)
22322         opt = dx(1)**2+dx(2)**2
22323         rsecp = opt+dx(3)**2
22324         rs = sqrt(rsecp)
22325         rthrp = rsecp*rs
22326         rfourp = rthrp*rs
22327         rsixp = rfourp*rsecp
22328         reight=rsixp*rsecp
22329         Ir = 1.0d0/rs
22330         Irsecp = 1/rsecp
22331         Irthrp = Irsecp/rs
22332         Irfourp = Irthrp/rs
22333         Irsixp = 1/rsixp
22334         Ireight=1/reight
22335         Irtw=Irsixp*Irsixp
22336         Irthir=Irtw/rs
22337         Irfourt=Irthir/rs
22338         opt1 = (4*rs*dx(3)*wdip)
22339         opt2 = 6*rsecp*wquad1*opt
22340         opt3 = wquad1*wquad2p*Irsixp
22341         opt4 = (wvan1*wvan2**12)
22342         opt5 = opt4*12*Irfourt
22343         opt6 = 2*wvan1*wvan2**6
22344         opt7 = 6*opt6*Ireight
22345         opt8 = wdip/v1m
22346         opt10 = wdip/v2m
22347         opt11 = (rsecp*v2m)**2
22348         opt12 = (rsecp*v1m)**2
22349         opt14 = (v1m*v2m*rsecp)**2
22350         opt15 = -wquad1/v2m**2
22351         opt16 = (rthrp*(v1m*v2m)**2)**2
22352         opt17 = (v1m**2*rthrp)**2
22353         opt18 = -wquad1/rthrp
22354         opt19 = (v1m**2*v2m**2)**2
22355         Ec = wc*Ir
22356         do k=1,3
22357           dEcCat(k) = -(dx(k)*wc)*Irthrp
22358           dEcCm(k)=(dx(k)*wc)*Irthrp
22359           dEcCalp(k)=0.0d0
22360         enddo
22361         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22362         do k=1,3
22363           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
22364                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22365           dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
22366                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22367           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
22368                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
22369                       *v1dpv2)/opt14
22370         enddo
22371         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22372         do k=1,3
22373           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
22374                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
22375                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22376           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
22377                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
22378                       v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22379           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22380                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
22381                         v1dpv2**2)/opt19
22382         enddo
22383         Equad2=wquad1*wquad2p*Irthrp
22384         do k=1,3
22385           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22386           dEquad2Cm(k)=3*dx(k)*rs*opt3
22387           dEquad2Calp(k)=0.0d0
22388         enddo
22389         Evan1=opt4*Irtw
22390         do k=1,3
22391           dEvan1Cat(k)=-dx(k)*opt5
22392           dEvan1Cm(k)=dx(k)*opt5
22393           dEvan1Calp(k)=0.0d0
22394         enddo
22395         Evan2=-opt6*Irsixp
22396         do k=1,3
22397           dEvan2Cat(k)=dx(k)*opt7
22398           dEvan2Cm(k)=-dx(k)*opt7
22399           dEvan2Calp(k)=0.0d0
22400         enddo
22401         ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
22402 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
22403
22404         do k=1,3
22405           dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
22406                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22407 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
22408           dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
22409                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22410           dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
22411                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22412         enddo
22413             dscmag = 0.0d0
22414             do k=1,3
22415               dscvec(k) = dc(k,i+nres)
22416               dscmag = dscmag+dscvec(k)*dscvec(k)
22417             enddo
22418             dscmag3 = dscmag
22419             dscmag = sqrt(dscmag)
22420             dscmag3 = dscmag3*dscmag
22421             constA = 1.0d0+dASGL/dscmag
22422             constB = 0.0d0
22423             do k=1,3
22424               constB = constB+dscvec(k)*dEtotalCm(k)
22425             enddo
22426             constB = constB*dASGL/dscmag3
22427             do k=1,3
22428               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22429               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22430                constA*dEtotalCm(k)-constB*dscvec(k)
22431 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
22432               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22433               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22434              enddo
22435         else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
22436            if(itype(i,1).eq.14) then
22437             inum=3
22438             else
22439             inum=4
22440             endif
22441             do k=1,6
22442             vcatprm(k)=catprm(k,inum)
22443             enddo
22444             dASGL=catprm(7,inum)
22445              do k=1,3
22446                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22447                 valpha(k)=c(k,i)
22448                 vcat(k)=c(k,j)
22449               enddo
22450
22451         do k=1,3
22452           dx(k) = vcat(k)-vcm(k)
22453         enddo
22454         do k=1,3
22455           v1(k)=(vcm(k)-valpha(k))
22456           v2(k)=(vcat(k)-valpha(k))
22457         enddo
22458         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22459         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22460         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22461 !  The weights of the energy function calculated from
22462 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
22463         wh2o=78
22464         wdip =vcatprm(2)
22465         wdip=wdip/wh2o
22466         wquad1 =vcatprm(3)
22467         wquad1=wquad1/wh2o
22468         wquad2 = vcatprm(4)
22469         wquad2=wquad2/wh2o
22470         wquad2p = 1-wquad2
22471         wvan1 = vcatprm(5)
22472         wvan2 =vcatprm(6)
22473         opt = dx(1)**2+dx(2)**2
22474         rsecp = opt+dx(3)**2
22475         rs = sqrt(rsecp)
22476         rthrp = rsecp*rs
22477         rfourp = rthrp*rs
22478         rsixp = rfourp*rsecp
22479         reight=rsixp*rsecp
22480         Ir = 1.0d0/rs
22481         Irsecp = 1/rsecp
22482         Irthrp = Irsecp/rs
22483         Irfourp = Irthrp/rs
22484         Irsixp = 1/rsixp
22485         Ireight=1/reight
22486         Irtw=Irsixp*Irsixp
22487         Irthir=Irtw/rs
22488         Irfourt=Irthir/rs
22489         opt1 = (4*rs*dx(3)*wdip)
22490         opt2 = 6*rsecp*wquad1*opt
22491         opt3 = wquad1*wquad2p*Irsixp
22492         opt4 = (wvan1*wvan2**12)
22493         opt5 = opt4*12*Irfourt
22494         opt6 = 2*wvan1*wvan2**6
22495         opt7 = 6*opt6*Ireight
22496         opt8 = wdip/v1m
22497         opt10 = wdip/v2m
22498         opt11 = (rsecp*v2m)**2
22499         opt12 = (rsecp*v1m)**2
22500         opt14 = (v1m*v2m*rsecp)**2
22501         opt15 = -wquad1/v2m**2
22502         opt16 = (rthrp*(v1m*v2m)**2)**2
22503         opt17 = (v1m**2*rthrp)**2
22504         opt18 = -wquad1/rthrp
22505         opt19 = (v1m**2*v2m**2)**2
22506         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22507         do k=1,3
22508           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
22509                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22510          dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
22511                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22512           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
22513                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
22514                       *v1dpv2)/opt14
22515         enddo
22516         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22517         do k=1,3
22518           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
22519                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
22520                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22521           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
22522                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
22523                        v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22524           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22525                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
22526                         v1dpv2**2)/opt19
22527         enddo
22528         Equad2=wquad1*wquad2p*Irthrp
22529         do k=1,3
22530           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22531           dEquad2Cm(k)=3*dx(k)*rs*opt3
22532           dEquad2Calp(k)=0.0d0
22533         enddo
22534         Evan1=opt4*Irtw
22535         do k=1,3
22536           dEvan1Cat(k)=-dx(k)*opt5
22537           dEvan1Cm(k)=dx(k)*opt5
22538           dEvan1Calp(k)=0.0d0
22539         enddo
22540         Evan2=-opt6*Irsixp
22541         do k=1,3
22542           dEvan2Cat(k)=dx(k)*opt7
22543           dEvan2Cm(k)=-dx(k)*opt7
22544           dEvan2Calp(k)=0.0d0
22545         enddo
22546          ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
22547         do k=1,3
22548           dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
22549                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22550           dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
22551                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22552           dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
22553                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22554         enddo
22555             dscmag = 0.0d0
22556             do k=1,3
22557               dscvec(k) = c(k,i+nres)-c(k,i)
22558               dscmag = dscmag+dscvec(k)*dscvec(k)
22559             enddo
22560             dscmag3 = dscmag
22561             dscmag = sqrt(dscmag)
22562             dscmag3 = dscmag3*dscmag
22563             constA = 1+dASGL/dscmag
22564             constB = 0.0d0
22565             do k=1,3
22566               constB = constB+dscvec(k)*dEtotalCm(k)
22567             enddo
22568             constB = constB*dASGL/dscmag3
22569             do k=1,3
22570               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22571               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22572                constA*dEtotalCm(k)-constB*dscvec(k)
22573               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22574               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22575              enddo
22576            else
22577             rcal = 0.0d0
22578             do k=1,3
22579               r(k) = c(k,j)-c(k,i+nres)
22580               rcal = rcal+r(k)*r(k)
22581             enddo
22582             ract=sqrt(rcal)
22583             rocal=1.5
22584             epscalc=0.2
22585             r0p=0.5*(rocal+sig0(itype(i,1)))
22586             r06 = r0p**6
22587             r012 = r06*r06
22588             Evan1=epscalc*(r012/rcal**6)
22589             Evan2=epscalc*2*(r06/rcal**3)
22590             r4 = rcal**4
22591             r7 = rcal**7
22592             do k=1,3
22593               dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
22594               dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
22595             enddo
22596             do k=1,3
22597               dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
22598             enddo
22599                  ecation_prot = ecation_prot+ Evan1+Evan2
22600             do  k=1,3
22601                gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22602                dEtotalCm(k)
22603               gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
22604               gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
22605              enddo
22606          endif ! 13-16 residues
22607        enddo !j
22608        enddo !i
22609        return
22610        end subroutine ecat_prot
22611
22612 !----------------------------------------------------------------------------
22613 !-----------------------------------------------------------------------------
22614 !-----------------------------------------------------------------------------
22615       subroutine eprot_sc_base(escbase)
22616       use calc_data
22617 !      implicit real*8 (a-h,o-z)
22618 !      include 'DIMENSIONS'
22619 !      include 'COMMON.GEO'
22620 !      include 'COMMON.VAR'
22621 !      include 'COMMON.LOCAL'
22622 !      include 'COMMON.CHAIN'
22623 !      include 'COMMON.DERIV'
22624 !      include 'COMMON.NAMES'
22625 !      include 'COMMON.INTERACT'
22626 !      include 'COMMON.IOUNITS'
22627 !      include 'COMMON.CALC'
22628 !      include 'COMMON.CONTROL'
22629 !      include 'COMMON.SBRIDGE'
22630       logical :: lprn
22631 !el local variables
22632       integer :: iint,itypi,itypi1,itypj,subchap
22633       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
22634       real(kind=8) :: evdw,sig0ij
22635       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22636                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
22637                     sslipi,sslipj,faclip
22638       integer :: ii
22639       real(kind=8) :: fracinbuf
22640        real (kind=8) :: escbase
22641        real (kind=8),dimension(4):: ener
22642        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
22643        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
22644         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
22645         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
22646         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
22647         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
22648         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
22649         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
22650        real(kind=8),dimension(3,2)::chead,erhead_tail
22651        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
22652        integer troll
22653        eps_out=80.0d0
22654        escbase=0.0d0
22655 !       do i=1,nres_molec(1)
22656         do i=ibond_start,ibond_end
22657         if (itype(i,1).eq.ntyp1_molec(1)) cycle
22658         itypi  = itype(i,1)
22659         dxi    = dc_norm(1,nres+i)
22660         dyi    = dc_norm(2,nres+i)
22661         dzi    = dc_norm(3,nres+i)
22662         dsci_inv = vbld_inv(i+nres)
22663         xi=c(1,nres+i)
22664         yi=c(2,nres+i)
22665         zi=c(3,nres+i)
22666         xi=mod(xi,boxxsize)
22667          if (xi.lt.0) xi=xi+boxxsize
22668         yi=mod(yi,boxysize)
22669          if (yi.lt.0) yi=yi+boxysize
22670         zi=mod(zi,boxzsize)
22671          if (zi.lt.0) zi=zi+boxzsize
22672          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
22673            itypj= itype(j,2)
22674            if (itype(j,2).eq.ntyp1_molec(2))cycle
22675            xj=c(1,j+nres)
22676            yj=c(2,j+nres)
22677            zj=c(3,j+nres)
22678            xj=dmod(xj,boxxsize)
22679            if (xj.lt.0) xj=xj+boxxsize
22680            yj=dmod(yj,boxysize)
22681            if (yj.lt.0) yj=yj+boxysize
22682            zj=dmod(zj,boxzsize)
22683            if (zj.lt.0) zj=zj+boxzsize
22684           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22685           xj_safe=xj
22686           yj_safe=yj
22687           zj_safe=zj
22688           subchap=0
22689
22690           do xshift=-1,1
22691           do yshift=-1,1
22692           do zshift=-1,1
22693           xj=xj_safe+xshift*boxxsize
22694           yj=yj_safe+yshift*boxysize
22695           zj=zj_safe+zshift*boxzsize
22696           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22697           if(dist_temp.lt.dist_init) then
22698             dist_init=dist_temp
22699             xj_temp=xj
22700             yj_temp=yj
22701             zj_temp=zj
22702             subchap=1
22703           endif
22704           enddo
22705           enddo
22706           enddo
22707           if (subchap.eq.1) then
22708           xj=xj_temp-xi
22709           yj=yj_temp-yi
22710           zj=zj_temp-zi
22711           else
22712           xj=xj_safe-xi
22713           yj=yj_safe-yi
22714           zj=zj_safe-zi
22715           endif
22716           dxj = dc_norm( 1, nres+j )
22717           dyj = dc_norm( 2, nres+j )
22718           dzj = dc_norm( 3, nres+j )
22719 !          print *,i,j,itypi,itypj
22720           d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
22721           d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
22722 !          d1i=0.0d0
22723 !          d1j=0.0d0
22724 !          BetaT = 1.0d0 / (298.0d0 * Rb)
22725 ! Gay-berne var's
22726           sig0ij = sigma_scbase( itypi,itypj )
22727           chi1   = chi_scbase( itypi, itypj,1 )
22728           chi2   = chi_scbase( itypi, itypj,2 )
22729 !          chi1=0.0d0
22730 !          chi2=0.0d0
22731           chi12  = chi1 * chi2
22732           chip1  = chipp_scbase( itypi, itypj,1 )
22733           chip2  = chipp_scbase( itypi, itypj,2 )
22734 !          chip1=0.0d0
22735 !          chip2=0.0d0
22736           chip12 = chip1 * chip2
22737 ! not used by momo potential, but needed by sc_angular which is shared
22738 ! by all energy_potential subroutines
22739           alf1   = 0.0d0
22740           alf2   = 0.0d0
22741           alf12  = 0.0d0
22742           a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
22743 !       a12sq = a12sq * a12sq
22744 ! charge of amino acid itypi is...
22745           chis1 = chis_scbase(itypi,itypj,1)
22746           chis2 = chis_scbase(itypi,itypj,2)
22747           chis12 = chis1 * chis2
22748           sig1 = sigmap1_scbase(itypi,itypj)
22749           sig2 = sigmap2_scbase(itypi,itypj)
22750 !       write (*,*) "sig1 = ", sig1
22751 !       write (*,*) "sig2 = ", sig2
22752 ! alpha factors from Fcav/Gcav
22753           b1 = alphasur_scbase(1,itypi,itypj)
22754 !          b1=0.0d0
22755           b2 = alphasur_scbase(2,itypi,itypj)
22756           b3 = alphasur_scbase(3,itypi,itypj)
22757           b4 = alphasur_scbase(4,itypi,itypj)
22758 ! used to determine whether we want to do quadrupole calculations
22759 ! used by Fgb
22760        eps_in = epsintab_scbase(itypi,itypj)
22761        if (eps_in.eq.0.0) eps_in=1.0
22762        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22763 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
22764 !-------------------------------------------------------------------
22765 ! tail location and distance calculations
22766        DO k = 1,3
22767 ! location of polar head is computed by taking hydrophobic centre
22768 ! and moving by a d1 * dc_norm vector
22769 ! see unres publications for very informative images
22770         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
22771         chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
22772 ! distance
22773 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22774 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22775         Rhead_distance(k) = chead(k,2) - chead(k,1)
22776        END DO
22777 ! pitagoras (root of sum of squares)
22778        Rhead = dsqrt( &
22779           (Rhead_distance(1)*Rhead_distance(1)) &
22780         + (Rhead_distance(2)*Rhead_distance(2)) &
22781         + (Rhead_distance(3)*Rhead_distance(3)))
22782 !-------------------------------------------------------------------
22783 ! zero everything that should be zero'ed
22784        evdwij = 0.0d0
22785        ECL = 0.0d0
22786        Elj = 0.0d0
22787        Equad = 0.0d0
22788        Epol = 0.0d0
22789        Fcav=0.0d0
22790        eheadtail = 0.0d0
22791        dGCLdOM1 = 0.0d0
22792        dGCLdOM2 = 0.0d0
22793        dGCLdOM12 = 0.0d0
22794        dPOLdOM1 = 0.0d0
22795        dPOLdOM2 = 0.0d0
22796           Fcav = 0.0d0
22797           dFdR = 0.0d0
22798           dCAVdOM1  = 0.0d0
22799           dCAVdOM2  = 0.0d0
22800           dCAVdOM12 = 0.0d0
22801           dscj_inv = vbld_inv(j+nres)
22802 !          print *,i,j,dscj_inv,dsci_inv
22803 ! rij holds 1/(distance of Calpha atoms)
22804           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22805           rij  = dsqrt(rrij)
22806 !----------------------------
22807           CALL sc_angular
22808 ! this should be in elgrad_init but om's are calculated by sc_angular
22809 ! which in turn is used by older potentials
22810 ! om = omega, sqom = om^2
22811           sqom1  = om1 * om1
22812           sqom2  = om2 * om2
22813           sqom12 = om12 * om12
22814
22815 ! now we calculate EGB - Gey-Berne
22816 ! It will be summed up in evdwij and saved in evdw
22817           sigsq     = 1.0D0  / sigsq
22818           sig       = sig0ij * dsqrt(sigsq)
22819 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22820           rij_shift = 1.0/rij - sig + sig0ij
22821           IF (rij_shift.le.0.0D0) THEN
22822            evdw = 1.0D20
22823            RETURN
22824           END IF
22825           sigder = -sig * sigsq
22826           rij_shift = 1.0D0 / rij_shift
22827           fac       = rij_shift**expon
22828           c1        = fac  * fac * aa_scbase(itypi,itypj)
22829 !          c1        = 0.0d0
22830           c2        = fac  * bb_scbase(itypi,itypj)
22831 !          c2        = 0.0d0
22832           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22833           eps2der   = eps3rt * evdwij
22834           eps3der   = eps2rt * evdwij
22835 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22836           evdwij    = eps2rt * eps3rt * evdwij
22837           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22838           fac    = -expon * (c1 + evdwij) * rij_shift
22839           sigder = fac * sigder
22840 !          fac    = rij * fac
22841 ! Calculate distance derivative
22842           gg(1) =  fac
22843           gg(2) =  fac
22844           gg(3) =  fac
22845 !          if (b2.gt.0.0) then
22846           fac = chis1 * sqom1 + chis2 * sqom2 &
22847           - 2.0d0 * chis12 * om1 * om2 * om12
22848 ! we will use pom later in Gcav, so dont mess with it!
22849           pom = 1.0d0 - chis1 * chis2 * sqom12
22850           Lambf = (1.0d0 - (fac / pom))
22851           Lambf = dsqrt(Lambf)
22852           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
22853 !       write (*,*) "sparrow = ", sparrow
22854           Chif = 1.0d0/rij * sparrow
22855           ChiLambf = Chif * Lambf
22856           eagle = dsqrt(ChiLambf)
22857           bat = ChiLambf ** 11.0d0
22858           top = b1 * ( eagle + b2 * ChiLambf - b3 )
22859           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
22860           botsq = bot * bot
22861           Fcav = top / bot
22862 !          print *,i,j,Fcav
22863           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
22864           dbot = 12.0d0 * b4 * bat * Lambf
22865           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
22866 !       dFdR = 0.0d0
22867 !      write (*,*) "dFcav/dR = ", dFdR
22868           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
22869           dbot = 12.0d0 * b4 * bat * Chif
22870           eagle = Lambf * pom
22871           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
22872           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
22873           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
22874               * (chis2 * om2 * om12 - om1) / (eagle * pom)
22875
22876           dFdL = ((dtop * bot - top * dbot) / botsq)
22877 !       dFdL = 0.0d0
22878           dCAVdOM1  = dFdL * ( dFdOM1 )
22879           dCAVdOM2  = dFdL * ( dFdOM2 )
22880           dCAVdOM12 = dFdL * ( dFdOM12 )
22881
22882           ertail(1) = xj*rij
22883           ertail(2) = yj*rij
22884           ertail(3) = zj*rij
22885 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
22886 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
22887 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
22888 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
22889 !           print *,"EOMY",eom1,eom2,eom12
22890 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
22891 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
22892 ! here dtail=0.0
22893 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
22894 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
22895        DO k = 1, 3
22896 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
22897 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
22898         pom = ertail(k)
22899 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
22900         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
22901                   - (( dFdR + gg(k) ) * pom)
22902 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
22903 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22904 !     &             - ( dFdR * pom )
22905         pom = ertail(k)
22906 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
22907         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
22908                   + (( dFdR + gg(k) ) * pom)
22909 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22910 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22911 !c!     &             + ( dFdR * pom )
22912
22913         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
22914                   - (( dFdR + gg(k) ) * ertail(k))
22915 !c!     &             - ( dFdR * ertail(k))
22916
22917         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
22918                   + (( dFdR + gg(k) ) * ertail(k))
22919 !c!     &             + ( dFdR * ertail(k))
22920
22921         gg(k) = 0.0d0
22922 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
22923 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
22924       END DO
22925
22926 !          else
22927
22928 !          endif
22929 !Now dipole-dipole
22930          if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
22931        w1 = wdipdip_scbase(1,itypi,itypj)
22932        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
22933        w3 = wdipdip_scbase(2,itypi,itypj)
22934 !c!-------------------------------------------------------------------
22935 !c! ECL
22936        fac = (om12 - 3.0d0 * om1 * om2)
22937        c1 = (w1 / (Rhead**3.0d0)) * fac
22938        c2 = (w2 / Rhead ** 6.0d0)  &
22939          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
22940        c3= (w3/ Rhead ** 6.0d0)  &
22941          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
22942        ECL = c1 - c2 + c3
22943 !c!       write (*,*) "w1 = ", w1
22944 !c!       write (*,*) "w2 = ", w2
22945 !c!       write (*,*) "om1 = ", om1
22946 !c!       write (*,*) "om2 = ", om2
22947 !c!       write (*,*) "om12 = ", om12
22948 !c!       write (*,*) "fac = ", fac
22949 !c!       write (*,*) "c1 = ", c1
22950 !c!       write (*,*) "c2 = ", c2
22951 !c!       write (*,*) "Ecl = ", Ecl
22952 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
22953 !c!       write (*,*) "c2_2 = ",
22954 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
22955 !c!-------------------------------------------------------------------
22956 !c! dervative of ECL is GCL...
22957 !c! dECL/dr
22958        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
22959        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
22960          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
22961        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
22962          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
22963        dGCLdR = c1 - c2 + c3
22964 !c! dECL/dom1
22965        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
22966        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
22967          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
22968        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
22969        dGCLdOM1 = c1 - c2 + c3
22970 !c! dECL/dom2
22971        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
22972        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
22973          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
22974        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
22975        dGCLdOM2 = c1 - c2 + c3
22976 !c! dECL/dom12
22977        c1 = w1 / (Rhead ** 3.0d0)
22978        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
22979        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
22980        dGCLdOM12 = c1 - c2 + c3
22981        DO k= 1, 3
22982         erhead(k) = Rhead_distance(k)/Rhead
22983        END DO
22984        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
22985        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
22986        facd1 = d1i * vbld_inv(i+nres)
22987        facd2 = d1j * vbld_inv(j+nres)
22988        DO k = 1, 3
22989
22990         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
22991         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
22992                   - dGCLdR * pom
22993         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
22994         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
22995                   + dGCLdR * pom
22996
22997         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
22998                   - dGCLdR * erhead(k)
22999         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
23000                   + dGCLdR * erhead(k)
23001        END DO
23002        endif
23003 !now charge with dipole eg. ARG-dG
23004        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
23005       alphapol1 = alphapol_scbase(itypi,itypj)
23006        w1        = wqdip_scbase(1,itypi,itypj)
23007        w2        = wqdip_scbase(2,itypi,itypj)
23008 !       w1=0.0d0
23009 !       w2=0.0d0
23010 !       pis       = sig0head_scbase(itypi,itypj)
23011 !       eps_head   = epshead_scbase(itypi,itypj)
23012 !c!-------------------------------------------------------------------
23013 !c! R1 - distance between head of ith side chain and tail of jth sidechain
23014        R1 = 0.0d0
23015        DO k = 1, 3
23016 !c! Calculate head-to-tail distances tail is center of side-chain
23017         R1=R1+(c(k,j+nres)-chead(k,1))**2
23018        END DO
23019 !c! Pitagoras
23020        R1 = dsqrt(R1)
23021
23022 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
23023 !c!     &        +dhead(1,1,itypi,itypj))**2))
23024 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
23025 !c!     &        +dhead(2,1,itypi,itypj))**2))
23026
23027 !c!-------------------------------------------------------------------
23028 !c! ecl
23029        sparrow  = w1  *  om1
23030        hawk     = w2 *  (1.0d0 - sqom2)
23031        Ecl = sparrow / Rhead**2.0d0 &
23032            - hawk    / Rhead**4.0d0
23033 !c!-------------------------------------------------------------------
23034 !c! derivative of ecl is Gcl
23035 !c! dF/dr part
23036        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
23037                 + 4.0d0 * hawk    / Rhead**5.0d0
23038 !c! dF/dom1
23039        dGCLdOM1 = (w1) / (Rhead**2.0d0)
23040 !c! dF/dom2
23041        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
23042 !c--------------------------------------------------------------------
23043 !c Polarization energy
23044 !c Epol
23045        MomoFac1 = (1.0d0 - chi1 * sqom2)
23046        RR1  = R1 * R1 / MomoFac1
23047        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
23048        fgb1 = sqrt( RR1 + a12sq * ee1)
23049 !       eps_inout_fac=0.0d0
23050        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
23051 ! derivative of Epol is Gpol...
23052        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
23053                 / (fgb1 ** 5.0d0)
23054        dFGBdR1 = ( (R1 / MomoFac1) &
23055              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
23056              / ( 2.0d0 * fgb1 )
23057        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
23058                * (2.0d0 - 0.5d0 * ee1) ) &
23059                / (2.0d0 * fgb1)
23060        dPOLdR1 = dPOLdFGB1 * dFGBdR1
23061 !       dPOLdR1 = 0.0d0
23062        dPOLdOM1 = 0.0d0
23063        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
23064        DO k = 1, 3
23065         erhead(k) = Rhead_distance(k)/Rhead
23066         erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
23067        END DO
23068
23069        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23070        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23071        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
23072 !       bat=0.0d0
23073        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
23074        facd1 = d1i * vbld_inv(i+nres)
23075        facd2 = d1j * vbld_inv(j+nres)
23076 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23077
23078        DO k = 1, 3
23079         hawk = (erhead_tail(k,1) + &
23080         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
23081 !        facd1=0.0d0
23082 !        facd2=0.0d0
23083         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23084         gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
23085                    - dGCLdR * pom &
23086                    - dPOLdR1 *  (erhead_tail(k,1))
23087 !     &             - dGLJdR * pom
23088
23089         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23090         gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
23091                    + dGCLdR * pom  &
23092                    + dPOLdR1 * (erhead_tail(k,1))
23093 !     &             + dGLJdR * pom
23094
23095
23096         gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
23097                   - dGCLdR * erhead(k) &
23098                   - dPOLdR1 * erhead_tail(k,1)
23099 !     &             - dGLJdR * erhead(k)
23100
23101         gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
23102                   + dGCLdR * erhead(k)  &
23103                   + dPOLdR1 * erhead_tail(k,1)
23104 !     &             + dGLJdR * erhead(k)
23105
23106        END DO
23107        endif
23108 !       print *,i,j,evdwij,epol,Fcav,ECL
23109        escbase=escbase+evdwij+epol+Fcav+ECL
23110        call sc_grad_scbase
23111          enddo
23112       enddo
23113
23114       return
23115       end subroutine eprot_sc_base
23116       SUBROUTINE sc_grad_scbase
23117       use calc_data
23118
23119        real (kind=8) :: dcosom1(3),dcosom2(3)
23120        eom1  =    &
23121               eps2der * eps2rt_om1   &
23122             - 2.0D0 * alf1 * eps3der &
23123             + sigder * sigsq_om1     &
23124             + dCAVdOM1               &
23125             + dGCLdOM1               &
23126             + dPOLdOM1
23127
23128        eom2  =  &
23129               eps2der * eps2rt_om2   &
23130             + 2.0D0 * alf2 * eps3der &
23131             + sigder * sigsq_om2     &
23132             + dCAVdOM2               &
23133             + dGCLdOM2               &
23134             + dPOLdOM2
23135
23136        eom12 =    &
23137               evdwij  * eps1_om12     &
23138             + eps2der * eps2rt_om12   &
23139             - 2.0D0 * alf12 * eps3der &
23140             + sigder *sigsq_om12      &
23141             + dCAVdOM12               &
23142             + dGCLdOM12
23143
23144 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23145 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23146 !               gg(1),gg(2),"rozne"
23147        DO k = 1, 3
23148         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
23149         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
23150         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23151         gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
23152                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23153                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23154         gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
23155                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23156                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23157         gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
23158         gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
23159        END DO
23160        RETURN
23161       END SUBROUTINE sc_grad_scbase
23162
23163
23164       subroutine epep_sc_base(epepbase)
23165       use calc_data
23166       logical :: lprn
23167 !el local variables
23168       integer :: iint,itypi,itypi1,itypj,subchap
23169       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23170       real(kind=8) :: evdw,sig0ij
23171       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23172                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23173                     sslipi,sslipj,faclip
23174       integer :: ii
23175       real(kind=8) :: fracinbuf
23176        real (kind=8) :: epepbase
23177        real (kind=8),dimension(4):: ener
23178        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23179        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23180         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
23181         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23182         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23183         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23184         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23185         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23186        real(kind=8),dimension(3,2)::chead,erhead_tail
23187        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23188        integer troll
23189        eps_out=80.0d0
23190        epepbase=0.0d0
23191 !       do i=1,nres_molec(1)-1
23192         do i=ibond_start,ibond_end
23193         if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
23194 !C        itypi  = itype(i,1)
23195         dxi    = dc_norm(1,i)
23196         dyi    = dc_norm(2,i)
23197         dzi    = dc_norm(3,i)
23198 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
23199         dsci_inv = vbld_inv(i+1)/2.0
23200         xi=(c(1,i)+c(1,i+1))/2.0
23201         yi=(c(2,i)+c(2,i+1))/2.0
23202         zi=(c(3,i)+c(3,i+1))/2.0
23203         xi=mod(xi,boxxsize)
23204          if (xi.lt.0) xi=xi+boxxsize
23205         yi=mod(yi,boxysize)
23206          if (yi.lt.0) yi=yi+boxysize
23207         zi=mod(zi,boxzsize)
23208          if (zi.lt.0) zi=zi+boxzsize
23209          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23210            itypj= itype(j,2)
23211            if (itype(j,2).eq.ntyp1_molec(2))cycle
23212            xj=c(1,j+nres)
23213            yj=c(2,j+nres)
23214            zj=c(3,j+nres)
23215            xj=dmod(xj,boxxsize)
23216            if (xj.lt.0) xj=xj+boxxsize
23217            yj=dmod(yj,boxysize)
23218            if (yj.lt.0) yj=yj+boxysize
23219            zj=dmod(zj,boxzsize)
23220            if (zj.lt.0) zj=zj+boxzsize
23221           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23222           xj_safe=xj
23223           yj_safe=yj
23224           zj_safe=zj
23225           subchap=0
23226
23227           do xshift=-1,1
23228           do yshift=-1,1
23229           do zshift=-1,1
23230           xj=xj_safe+xshift*boxxsize
23231           yj=yj_safe+yshift*boxysize
23232           zj=zj_safe+zshift*boxzsize
23233           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23234           if(dist_temp.lt.dist_init) then
23235             dist_init=dist_temp
23236             xj_temp=xj
23237             yj_temp=yj
23238             zj_temp=zj
23239             subchap=1
23240           endif
23241           enddo
23242           enddo
23243           enddo
23244           if (subchap.eq.1) then
23245           xj=xj_temp-xi
23246           yj=yj_temp-yi
23247           zj=zj_temp-zi
23248           else
23249           xj=xj_safe-xi
23250           yj=yj_safe-yi
23251           zj=zj_safe-zi
23252           endif
23253           dxj = dc_norm( 1, nres+j )
23254           dyj = dc_norm( 2, nres+j )
23255           dzj = dc_norm( 3, nres+j )
23256 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
23257 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
23258
23259 ! Gay-berne var's
23260           sig0ij = sigma_pepbase(itypj )
23261           chi1   = chi_pepbase(itypj,1 )
23262           chi2   = chi_pepbase(itypj,2 )
23263 !          chi1=0.0d0
23264 !          chi2=0.0d0
23265           chi12  = chi1 * chi2
23266           chip1  = chipp_pepbase(itypj,1 )
23267           chip2  = chipp_pepbase(itypj,2 )
23268 !          chip1=0.0d0
23269 !          chip2=0.0d0
23270           chip12 = chip1 * chip2
23271           chis1 = chis_pepbase(itypj,1)
23272           chis2 = chis_pepbase(itypj,2)
23273           chis12 = chis1 * chis2
23274           sig1 = sigmap1_pepbase(itypj)
23275           sig2 = sigmap2_pepbase(itypj)
23276 !       write (*,*) "sig1 = ", sig1
23277 !       write (*,*) "sig2 = ", sig2
23278        DO k = 1,3
23279 ! location of polar head is computed by taking hydrophobic centre
23280 ! and moving by a d1 * dc_norm vector
23281 ! see unres publications for very informative images
23282         chead(k,1) = (c(k,i)+c(k,i+1))/2.0
23283 ! + d1i * dc_norm(k, i+nres)
23284         chead(k,2) = c(k, j+nres)
23285 ! + d1j * dc_norm(k, j+nres)
23286 ! distance
23287 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23288 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23289         Rhead_distance(k) = chead(k,2) - chead(k,1)
23290 !        print *,gvdwc_pepbase(k,i)
23291
23292        END DO
23293        Rhead = dsqrt( &
23294           (Rhead_distance(1)*Rhead_distance(1)) &
23295         + (Rhead_distance(2)*Rhead_distance(2)) &
23296         + (Rhead_distance(3)*Rhead_distance(3)))
23297
23298 ! alpha factors from Fcav/Gcav
23299           b1 = alphasur_pepbase(1,itypj)
23300 !          b1=0.0d0
23301           b2 = alphasur_pepbase(2,itypj)
23302           b3 = alphasur_pepbase(3,itypj)
23303           b4 = alphasur_pepbase(4,itypj)
23304           alf1   = 0.0d0
23305           alf2   = 0.0d0
23306           alf12  = 0.0d0
23307           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23308 !          print *,i,j,rrij
23309           rij  = dsqrt(rrij)
23310 !----------------------------
23311        evdwij = 0.0d0
23312        ECL = 0.0d0
23313        Elj = 0.0d0
23314        Equad = 0.0d0
23315        Epol = 0.0d0
23316        Fcav=0.0d0
23317        eheadtail = 0.0d0
23318        dGCLdOM1 = 0.0d0
23319        dGCLdOM2 = 0.0d0
23320        dGCLdOM12 = 0.0d0
23321        dPOLdOM1 = 0.0d0
23322        dPOLdOM2 = 0.0d0
23323           Fcav = 0.0d0
23324           dFdR = 0.0d0
23325           dCAVdOM1  = 0.0d0
23326           dCAVdOM2  = 0.0d0
23327           dCAVdOM12 = 0.0d0
23328           dscj_inv = vbld_inv(j+nres)
23329           CALL sc_angular
23330 ! this should be in elgrad_init but om's are calculated by sc_angular
23331 ! which in turn is used by older potentials
23332 ! om = omega, sqom = om^2
23333           sqom1  = om1 * om1
23334           sqom2  = om2 * om2
23335           sqom12 = om12 * om12
23336
23337 ! now we calculate EGB - Gey-Berne
23338 ! It will be summed up in evdwij and saved in evdw
23339           sigsq     = 1.0D0  / sigsq
23340           sig       = sig0ij * dsqrt(sigsq)
23341           rij_shift = 1.0/rij - sig + sig0ij
23342           IF (rij_shift.le.0.0D0) THEN
23343            evdw = 1.0D20
23344            RETURN
23345           END IF
23346           sigder = -sig * sigsq
23347           rij_shift = 1.0D0 / rij_shift
23348           fac       = rij_shift**expon
23349           c1        = fac  * fac * aa_pepbase(itypj)
23350 !          c1        = 0.0d0
23351           c2        = fac  * bb_pepbase(itypj)
23352 !          c2        = 0.0d0
23353           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23354           eps2der   = eps3rt * evdwij
23355           eps3der   = eps2rt * evdwij
23356 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23357           evdwij    = eps2rt * eps3rt * evdwij
23358           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23359           fac    = -expon * (c1 + evdwij) * rij_shift
23360           sigder = fac * sigder
23361 !          fac    = rij * fac
23362 ! Calculate distance derivative
23363           gg(1) =  fac
23364           gg(2) =  fac
23365           gg(3) =  fac
23366           fac = chis1 * sqom1 + chis2 * sqom2 &
23367           - 2.0d0 * chis12 * om1 * om2 * om12
23368 ! we will use pom later in Gcav, so dont mess with it!
23369           pom = 1.0d0 - chis1 * chis2 * sqom12
23370           Lambf = (1.0d0 - (fac / pom))
23371           Lambf = dsqrt(Lambf)
23372           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23373 !       write (*,*) "sparrow = ", sparrow
23374           Chif = 1.0d0/rij * sparrow
23375           ChiLambf = Chif * Lambf
23376           eagle = dsqrt(ChiLambf)
23377           bat = ChiLambf ** 11.0d0
23378           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23379           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23380           botsq = bot * bot
23381           Fcav = top / bot
23382 !          print *,i,j,Fcav
23383           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23384           dbot = 12.0d0 * b4 * bat * Lambf
23385           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23386 !       dFdR = 0.0d0
23387 !      write (*,*) "dFcav/dR = ", dFdR
23388           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23389           dbot = 12.0d0 * b4 * bat * Chif
23390           eagle = Lambf * pom
23391           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23392           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23393           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23394               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23395
23396           dFdL = ((dtop * bot - top * dbot) / botsq)
23397 !       dFdL = 0.0d0
23398           dCAVdOM1  = dFdL * ( dFdOM1 )
23399           dCAVdOM2  = dFdL * ( dFdOM2 )
23400           dCAVdOM12 = dFdL * ( dFdOM12 )
23401
23402           ertail(1) = xj*rij
23403           ertail(2) = yj*rij
23404           ertail(3) = zj*rij
23405        DO k = 1, 3
23406 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23407 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23408         pom = ertail(k)
23409 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23410         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
23411                   - (( dFdR + gg(k) ) * pom)/2.0
23412 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
23413 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23414 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23415 !     &             - ( dFdR * pom )
23416         pom = ertail(k)
23417 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23418         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
23419                   + (( dFdR + gg(k) ) * pom)
23420 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23421 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23422 !c!     &             + ( dFdR * pom )
23423
23424         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
23425                   - (( dFdR + gg(k) ) * ertail(k))/2.0
23426 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
23427
23428 !c!     &             - ( dFdR * ertail(k))
23429
23430         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
23431                   + (( dFdR + gg(k) ) * ertail(k))
23432 !c!     &             + ( dFdR * ertail(k))
23433
23434         gg(k) = 0.0d0
23435 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23436 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23437       END DO
23438
23439
23440        w1 = wdipdip_pepbase(1,itypj)
23441        w2 = -wdipdip_pepbase(3,itypj)/2.0
23442        w3 = wdipdip_pepbase(2,itypj)
23443 !       w1=0.0d0
23444 !       w2=0.0d0
23445 !c!-------------------------------------------------------------------
23446 !c! ECL
23447 !       w3=0.0d0
23448        fac = (om12 - 3.0d0 * om1 * om2)
23449        c1 = (w1 / (Rhead**3.0d0)) * fac
23450        c2 = (w2 / Rhead ** 6.0d0)  &
23451          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23452        c3= (w3/ Rhead ** 6.0d0)  &
23453          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23454
23455        ECL = c1 - c2 + c3
23456
23457        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
23458        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
23459          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
23460        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
23461          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23462
23463        dGCLdR = c1 - c2 + c3
23464 !c! dECL/dom1
23465        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
23466        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23467          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
23468        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
23469        dGCLdOM1 = c1 - c2 + c3
23470 !c! dECL/dom2
23471        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
23472        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23473          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
23474        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
23475
23476        dGCLdOM2 = c1 - c2 + c3
23477 !c! dECL/dom12
23478        c1 = w1 / (Rhead ** 3.0d0)
23479        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
23480        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
23481        dGCLdOM12 = c1 - c2 + c3
23482        DO k= 1, 3
23483         erhead(k) = Rhead_distance(k)/Rhead
23484        END DO
23485        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23486        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23487 !       facd1 = d1 * vbld_inv(i+nres)
23488 !       facd2 = d2 * vbld_inv(j+nres)
23489        DO k = 1, 3
23490
23491 !        pom = erhead(k)
23492 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23493 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
23494 !                  - dGCLdR * pom
23495         pom = erhead(k)
23496 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23497         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
23498                   + dGCLdR * pom
23499
23500         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
23501                   - dGCLdR * erhead(k)/2.0d0
23502 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
23503         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
23504                   - dGCLdR * erhead(k)/2.0d0
23505 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
23506         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
23507                   + dGCLdR * erhead(k)
23508        END DO
23509 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
23510        epepbase=epepbase+evdwij+Fcav+ECL
23511        call sc_grad_pepbase
23512        enddo
23513        enddo
23514       END SUBROUTINE epep_sc_base
23515       SUBROUTINE sc_grad_pepbase
23516       use calc_data
23517
23518        real (kind=8) :: dcosom1(3),dcosom2(3)
23519        eom1  =    &
23520               eps2der * eps2rt_om1   &
23521             - 2.0D0 * alf1 * eps3der &
23522             + sigder * sigsq_om1     &
23523             + dCAVdOM1               &
23524             + dGCLdOM1               &
23525             + dPOLdOM1
23526
23527        eom2  =  &
23528               eps2der * eps2rt_om2   &
23529             + 2.0D0 * alf2 * eps3der &
23530             + sigder * sigsq_om2     &
23531             + dCAVdOM2               &
23532             + dGCLdOM2               &
23533             + dPOLdOM2
23534
23535        eom12 =    &
23536               evdwij  * eps1_om12     &
23537             + eps2der * eps2rt_om12   &
23538             - 2.0D0 * alf12 * eps3der &
23539             + sigder *sigsq_om12      &
23540             + dCAVdOM12               &
23541             + dGCLdOM12
23542 !        om12=0.0
23543 !        eom12=0.0
23544 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23545 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
23546 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23547 !                 *dsci_inv*2.0
23548 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23549 !               gg(1),gg(2),"rozne"
23550        DO k = 1, 3
23551         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
23552         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
23553         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23554         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
23555                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23556                  *dsci_inv*2.0 &
23557                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
23558         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
23559                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
23560                  *dsci_inv*2.0 &
23561                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
23562 !         print *,eom12,eom2,om12,om2
23563 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
23564 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
23565         gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
23566                  + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
23567                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23568         gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
23569        END DO
23570        RETURN
23571       END SUBROUTINE sc_grad_pepbase
23572       subroutine eprot_sc_phosphate(escpho)
23573       use calc_data
23574 !      implicit real*8 (a-h,o-z)
23575 !      include 'DIMENSIONS'
23576 !      include 'COMMON.GEO'
23577 !      include 'COMMON.VAR'
23578 !      include 'COMMON.LOCAL'
23579 !      include 'COMMON.CHAIN'
23580 !      include 'COMMON.DERIV'
23581 !      include 'COMMON.NAMES'
23582 !      include 'COMMON.INTERACT'
23583 !      include 'COMMON.IOUNITS'
23584 !      include 'COMMON.CALC'
23585 !      include 'COMMON.CONTROL'
23586 !      include 'COMMON.SBRIDGE'
23587       logical :: lprn
23588 !el local variables
23589       integer :: iint,itypi,itypi1,itypj,subchap
23590       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23591       real(kind=8) :: evdw,sig0ij
23592       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23593                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23594                     sslipi,sslipj,faclip,alpha_sco
23595       integer :: ii
23596       real(kind=8) :: fracinbuf
23597        real (kind=8) :: escpho
23598        real (kind=8),dimension(4):: ener
23599        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23600        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23601         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
23602         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23603         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
23604         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23605         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23606         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
23607        real(kind=8),dimension(3,2)::chead,erhead_tail
23608        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23609        integer troll
23610        eps_out=80.0d0
23611        escpho=0.0d0
23612 !       do i=1,nres_molec(1)
23613         do i=ibond_start,ibond_end
23614         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23615         itypi  = itype(i,1)
23616         dxi    = dc_norm(1,nres+i)
23617         dyi    = dc_norm(2,nres+i)
23618         dzi    = dc_norm(3,nres+i)
23619         dsci_inv = vbld_inv(i+nres)
23620         xi=c(1,nres+i)
23621         yi=c(2,nres+i)
23622         zi=c(3,nres+i)
23623         xi=mod(xi,boxxsize)
23624          if (xi.lt.0) xi=xi+boxxsize
23625         yi=mod(yi,boxysize)
23626          if (yi.lt.0) yi=yi+boxysize
23627         zi=mod(zi,boxzsize)
23628          if (zi.lt.0) zi=zi+boxzsize
23629          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
23630            itypj= itype(j,2)
23631            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
23632             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
23633            xj=(c(1,j)+c(1,j+1))/2.0
23634            yj=(c(2,j)+c(2,j+1))/2.0
23635            zj=(c(3,j)+c(3,j+1))/2.0
23636            xj=dmod(xj,boxxsize)
23637            if (xj.lt.0) xj=xj+boxxsize
23638            yj=dmod(yj,boxysize)
23639            if (yj.lt.0) yj=yj+boxysize
23640            zj=dmod(zj,boxzsize)
23641            if (zj.lt.0) zj=zj+boxzsize
23642           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23643           xj_safe=xj
23644           yj_safe=yj
23645           zj_safe=zj
23646           subchap=0
23647           do xshift=-1,1
23648           do yshift=-1,1
23649           do zshift=-1,1
23650           xj=xj_safe+xshift*boxxsize
23651           yj=yj_safe+yshift*boxysize
23652           zj=zj_safe+zshift*boxzsize
23653           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23654           if(dist_temp.lt.dist_init) then
23655             dist_init=dist_temp
23656             xj_temp=xj
23657             yj_temp=yj
23658             zj_temp=zj
23659             subchap=1
23660           endif
23661           enddo
23662           enddo
23663           enddo
23664           if (subchap.eq.1) then
23665           xj=xj_temp-xi
23666           yj=yj_temp-yi
23667           zj=zj_temp-zi
23668           else
23669           xj=xj_safe-xi
23670           yj=yj_safe-yi
23671           zj=zj_safe-zi
23672           endif
23673           dxj = dc_norm( 1,j )
23674           dyj = dc_norm( 2,j )
23675           dzj = dc_norm( 3,j )
23676           dscj_inv = vbld_inv(j+1)
23677
23678 ! Gay-berne var's
23679           sig0ij = sigma_scpho(itypi )
23680           chi1   = chi_scpho(itypi,1 )
23681           chi2   = chi_scpho(itypi,2 )
23682 !          chi1=0.0d0
23683 !          chi2=0.0d0
23684           chi12  = chi1 * chi2
23685           chip1  = chipp_scpho(itypi,1 )
23686           chip2  = chipp_scpho(itypi,2 )
23687 !          chip1=0.0d0
23688 !          chip2=0.0d0
23689           chip12 = chip1 * chip2
23690           chis1 = chis_scpho(itypi,1)
23691           chis2 = chis_scpho(itypi,2)
23692           chis12 = chis1 * chis2
23693           sig1 = sigmap1_scpho(itypi)
23694           sig2 = sigmap2_scpho(itypi)
23695 !       write (*,*) "sig1 = ", sig1
23696 !       write (*,*) "sig1 = ", sig1
23697 !       write (*,*) "sig2 = ", sig2
23698 ! alpha factors from Fcav/Gcav
23699           alf1   = 0.0d0
23700           alf2   = 0.0d0
23701           alf12  = 0.0d0
23702           a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
23703
23704           b1 = alphasur_scpho(1,itypi)
23705 !          b1=0.0d0
23706           b2 = alphasur_scpho(2,itypi)
23707           b3 = alphasur_scpho(3,itypi)
23708           b4 = alphasur_scpho(4,itypi)
23709 ! used to determine whether we want to do quadrupole calculations
23710 ! used by Fgb
23711        eps_in = epsintab_scpho(itypi)
23712        if (eps_in.eq.0.0) eps_in=1.0
23713        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23714 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23715 !-------------------------------------------------------------------
23716 ! tail location and distance calculations
23717           d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
23718           d1j = 0.0
23719        DO k = 1,3
23720 ! location of polar head is computed by taking hydrophobic centre
23721 ! and moving by a d1 * dc_norm vector
23722 ! see unres publications for very informative images
23723         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23724         chead(k,2) = (c(k, j) + c(k, j+1))/2.0
23725 ! distance
23726 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23727 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23728         Rhead_distance(k) = chead(k,2) - chead(k,1)
23729        END DO
23730 ! pitagoras (root of sum of squares)
23731        Rhead = dsqrt( &
23732           (Rhead_distance(1)*Rhead_distance(1)) &
23733         + (Rhead_distance(2)*Rhead_distance(2)) &
23734         + (Rhead_distance(3)*Rhead_distance(3)))
23735        Rhead_sq=Rhead**2.0
23736 !-------------------------------------------------------------------
23737 ! zero everything that should be zero'ed
23738        evdwij = 0.0d0
23739        ECL = 0.0d0
23740        Elj = 0.0d0
23741        Equad = 0.0d0
23742        Epol = 0.0d0
23743        Fcav=0.0d0
23744        eheadtail = 0.0d0
23745        dGCLdR=0.0d0
23746        dGCLdOM1 = 0.0d0
23747        dGCLdOM2 = 0.0d0
23748        dGCLdOM12 = 0.0d0
23749        dPOLdOM1 = 0.0d0
23750        dPOLdOM2 = 0.0d0
23751           Fcav = 0.0d0
23752           dFdR = 0.0d0
23753           dCAVdOM1  = 0.0d0
23754           dCAVdOM2  = 0.0d0
23755           dCAVdOM12 = 0.0d0
23756           dscj_inv = vbld_inv(j+1)/2.0
23757 !dhead_scbasej(itypi,itypj)
23758 !          print *,i,j,dscj_inv,dsci_inv
23759 ! rij holds 1/(distance of Calpha atoms)
23760           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23761           rij  = dsqrt(rrij)
23762 !----------------------------
23763           CALL sc_angular
23764 ! this should be in elgrad_init but om's are calculated by sc_angular
23765 ! which in turn is used by older potentials
23766 ! om = omega, sqom = om^2
23767           sqom1  = om1 * om1
23768           sqom2  = om2 * om2
23769           sqom12 = om12 * om12
23770
23771 ! now we calculate EGB - Gey-Berne
23772 ! It will be summed up in evdwij and saved in evdw
23773           sigsq     = 1.0D0  / sigsq
23774           sig       = sig0ij * dsqrt(sigsq)
23775 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23776           rij_shift = 1.0/rij - sig + sig0ij
23777           IF (rij_shift.le.0.0D0) THEN
23778            evdw = 1.0D20
23779            RETURN
23780           END IF
23781           sigder = -sig * sigsq
23782           rij_shift = 1.0D0 / rij_shift
23783           fac       = rij_shift**expon
23784           c1        = fac  * fac * aa_scpho(itypi)
23785 !          c1        = 0.0d0
23786           c2        = fac  * bb_scpho(itypi)
23787 !          c2        = 0.0d0
23788           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23789           eps2der   = eps3rt * evdwij
23790           eps3der   = eps2rt * evdwij
23791 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23792           evdwij    = eps2rt * eps3rt * evdwij
23793           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23794           fac    = -expon * (c1 + evdwij) * rij_shift
23795           sigder = fac * sigder
23796 !          fac    = rij * fac
23797 ! Calculate distance derivative
23798           gg(1) =  fac
23799           gg(2) =  fac
23800           gg(3) =  fac
23801           fac = chis1 * sqom1 + chis2 * sqom2 &
23802           - 2.0d0 * chis12 * om1 * om2 * om12
23803 ! we will use pom later in Gcav, so dont mess with it!
23804           pom = 1.0d0 - chis1 * chis2 * sqom12
23805           Lambf = (1.0d0 - (fac / pom))
23806           Lambf = dsqrt(Lambf)
23807           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23808 !       write (*,*) "sparrow = ", sparrow
23809           Chif = 1.0d0/rij * sparrow
23810           ChiLambf = Chif * Lambf
23811           eagle = dsqrt(ChiLambf)
23812           bat = ChiLambf ** 11.0d0
23813           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23814           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23815           botsq = bot * bot
23816           Fcav = top / bot
23817           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23818           dbot = 12.0d0 * b4 * bat * Lambf
23819           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23820 !       dFdR = 0.0d0
23821 !      write (*,*) "dFcav/dR = ", dFdR
23822           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23823           dbot = 12.0d0 * b4 * bat * Chif
23824           eagle = Lambf * pom
23825           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23826           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23827           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23828               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23829
23830           dFdL = ((dtop * bot - top * dbot) / botsq)
23831 !       dFdL = 0.0d0
23832           dCAVdOM1  = dFdL * ( dFdOM1 )
23833           dCAVdOM2  = dFdL * ( dFdOM2 )
23834           dCAVdOM12 = dFdL * ( dFdOM12 )
23835
23836           ertail(1) = xj*rij
23837           ertail(2) = yj*rij
23838           ertail(3) = zj*rij
23839        DO k = 1, 3
23840 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23841 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23842 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
23843
23844         pom = ertail(k)
23845 !        print *,pom,gg(k),dFdR
23846 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23847         gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
23848                   - (( dFdR + gg(k) ) * pom)
23849 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23850 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23851 !     &             - ( dFdR * pom )
23852 !        pom = ertail(k)
23853 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23854 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
23855 !                  + (( dFdR + gg(k) ) * pom)
23856 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23857 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23858 !c!     &             + ( dFdR * pom )
23859
23860         gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
23861                   - (( dFdR + gg(k) ) * ertail(k))
23862 !c!     &             - ( dFdR * ertail(k))
23863
23864         gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
23865                   + (( dFdR + gg(k) ) * ertail(k))/2.0
23866
23867         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
23868                   + (( dFdR + gg(k) ) * ertail(k))/2.0
23869
23870 !c!     &             + ( dFdR * ertail(k))
23871
23872         gg(k) = 0.0d0
23873         ENDDO
23874 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23875 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23876 !      alphapol1 = alphapol_scpho(itypi)
23877        if (wqq_scpho(itypi).ne.0.0) then
23878        Qij=wqq_scpho(itypi)/eps_in
23879        alpha_sco=1.d0/alphi_scpho(itypi)
23880 !       Qij=0.0
23881        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
23882 !c! derivative of Ecl is Gcl...
23883        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
23884                 (Rhead*alpha_sco+1) ) / Rhead_sq
23885        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
23886        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
23887        w1        = wqdip_scpho(1,itypi)
23888        w2        = wqdip_scpho(2,itypi)
23889 !       w1=0.0d0
23890 !       w2=0.0d0
23891 !       pis       = sig0head_scbase(itypi,itypj)
23892 !       eps_head   = epshead_scbase(itypi,itypj)
23893 !c!-------------------------------------------------------------------
23894
23895 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
23896 !c!     &        +dhead(1,1,itypi,itypj))**2))
23897 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
23898 !c!     &        +dhead(2,1,itypi,itypj))**2))
23899
23900 !c!-------------------------------------------------------------------
23901 !c! ecl
23902        sparrow  = w1  *  om1
23903        hawk     = w2 *  (1.0d0 - sqom2)
23904        Ecl = sparrow / Rhead**2.0d0 &
23905            - hawk    / Rhead**4.0d0
23906 !c!-------------------------------------------------------------------
23907        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
23908            1.0/rij,sparrow
23909
23910 !c! derivative of ecl is Gcl
23911 !c! dF/dr part
23912        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
23913                 + 4.0d0 * hawk    / Rhead**5.0d0
23914 !c! dF/dom1
23915        dGCLdOM1 = (w1) / (Rhead**2.0d0)
23916 !c! dF/dom2
23917        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
23918        endif
23919
23920 !c--------------------------------------------------------------------
23921 !c Polarization energy
23922 !c Epol
23923        R1 = 0.0d0
23924        DO k = 1, 3
23925 !c! Calculate head-to-tail distances tail is center of side-chain
23926         R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
23927        END DO
23928 !c! Pitagoras
23929        R1 = dsqrt(R1)
23930
23931       alphapol1 = alphapol_scpho(itypi)
23932 !      alphapol1=0.0
23933        MomoFac1 = (1.0d0 - chi2 * sqom1)
23934        RR1  = R1 * R1 / MomoFac1
23935        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
23936 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
23937        fgb1 = sqrt( RR1 + a12sq * ee1)
23938 !       eps_inout_fac=0.0d0
23939        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
23940 ! derivative of Epol is Gpol...
23941        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
23942                 / (fgb1 ** 5.0d0)
23943        dFGBdR1 = ( (R1 / MomoFac1) &
23944              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
23945              / ( 2.0d0 * fgb1 )
23946        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
23947                * (2.0d0 - 0.5d0 * ee1) ) &
23948                / (2.0d0 * fgb1)
23949        dPOLdR1 = dPOLdFGB1 * dFGBdR1
23950 !       dPOLdR1 = 0.0d0
23951 !       dPOLdOM1 = 0.0d0
23952        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
23953                * (2.0d0 - 0.5d0 * ee1) ) &
23954                / (2.0d0 * fgb1)
23955
23956        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
23957        dPOLdOM2 = 0.0
23958        DO k = 1, 3
23959         erhead(k) = Rhead_distance(k)/Rhead
23960         erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
23961        END DO
23962
23963        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23964        erdxj = scalar( erhead(1), dC_norm(1,j) )
23965        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
23966 !       bat=0.0d0
23967        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
23968        facd1 = d1i * vbld_inv(i+nres)
23969        facd2 = d1j * vbld_inv(j)
23970 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23971
23972        DO k = 1, 3
23973         hawk = (erhead_tail(k,1) + &
23974         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
23975 !        facd1=0.0d0
23976 !        facd2=0.0d0
23977 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
23978 !                pom,(erhead_tail(k,1))
23979
23980 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
23981         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23982         gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
23983                    - dGCLdR * pom &
23984                    - dPOLdR1 *  (erhead_tail(k,1))
23985 !     &             - dGLJdR * pom
23986
23987         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
23988 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
23989 !                   + dGCLdR * pom  &
23990 !                   + dPOLdR1 * (erhead_tail(k,1))
23991 !     &             + dGLJdR * pom
23992
23993
23994         gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
23995                   - dGCLdR * erhead(k) &
23996                   - dPOLdR1 * erhead_tail(k,1)
23997 !     &             - dGLJdR * erhead(k)
23998
23999         gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
24000                   + (dGCLdR * erhead(k)  &
24001                   + dPOLdR1 * erhead_tail(k,1))/2.0
24002         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
24003                   + (dGCLdR * erhead(k)  &
24004                   + dPOLdR1 * erhead_tail(k,1))/2.0
24005
24006 !     &             + dGLJdR * erhead(k)
24007 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
24008
24009        END DO
24010 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
24011        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
24012         "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
24013        escpho=escpho+evdwij+epol+Fcav+ECL
24014        call sc_grad_scpho
24015          enddo
24016
24017       enddo
24018
24019       return
24020       end subroutine eprot_sc_phosphate
24021       SUBROUTINE sc_grad_scpho
24022       use calc_data
24023
24024        real (kind=8) :: dcosom1(3),dcosom2(3)
24025        eom1  =    &
24026               eps2der * eps2rt_om1   &
24027             - 2.0D0 * alf1 * eps3der &
24028             + sigder * sigsq_om1     &
24029             + dCAVdOM1               &
24030             + dGCLdOM1               &
24031             + dPOLdOM1
24032
24033        eom2  =  &
24034               eps2der * eps2rt_om2   &
24035             + 2.0D0 * alf2 * eps3der &
24036             + sigder * sigsq_om2     &
24037             + dCAVdOM2               &
24038             + dGCLdOM2               &
24039             + dPOLdOM2
24040
24041        eom12 =    &
24042               evdwij  * eps1_om12     &
24043             + eps2der * eps2rt_om12   &
24044             - 2.0D0 * alf12 * eps3der &
24045             + sigder *sigsq_om12      &
24046             + dCAVdOM12               &
24047             + dGCLdOM12
24048 !        om12=0.0
24049 !        eom12=0.0
24050 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
24051 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
24052 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
24053 !                 *dsci_inv*2.0
24054 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
24055 !               gg(1),gg(2),"rozne"
24056        DO k = 1, 3
24057         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24058         dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
24059         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24060         gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
24061                  + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
24062                  *dscj_inv*2.0 &
24063                  - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24064         gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
24065                  - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
24066                  *dscj_inv*2.0 &
24067                  + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24068         gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
24069                  + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
24070                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24071
24072 !         print *,eom12,eom2,om12,om2
24073 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
24074 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
24075 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
24076 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
24077 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24078         gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
24079        END DO
24080        RETURN
24081       END SUBROUTINE sc_grad_scpho
24082       subroutine eprot_pep_phosphate(epeppho)
24083       use calc_data
24084 !      implicit real*8 (a-h,o-z)
24085 !      include 'DIMENSIONS'
24086 !      include 'COMMON.GEO'
24087 !      include 'COMMON.VAR'
24088 !      include 'COMMON.LOCAL'
24089 !      include 'COMMON.CHAIN'
24090 !      include 'COMMON.DERIV'
24091 !      include 'COMMON.NAMES'
24092 !      include 'COMMON.INTERACT'
24093 !      include 'COMMON.IOUNITS'
24094 !      include 'COMMON.CALC'
24095 !      include 'COMMON.CONTROL'
24096 !      include 'COMMON.SBRIDGE'
24097       logical :: lprn
24098 !el local variables
24099       integer :: iint,itypi,itypi1,itypj,subchap
24100       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
24101       real(kind=8) :: evdw,sig0ij
24102       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24103                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
24104                     sslipi,sslipj,faclip
24105       integer :: ii
24106       real(kind=8) :: fracinbuf
24107        real (kind=8) :: epeppho
24108        real (kind=8),dimension(4):: ener
24109        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
24110        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
24111         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
24112         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
24113         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
24114         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
24115         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
24116         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
24117        real(kind=8),dimension(3,2)::chead,erhead_tail
24118        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
24119        integer troll
24120        real (kind=8) :: dcosom1(3),dcosom2(3)
24121        epeppho=0.0d0
24122 !       do i=1,nres_molec(1)
24123         do i=ibond_start,ibond_end
24124         if (itype(i,1).eq.ntyp1_molec(1)) cycle
24125         itypi  = itype(i,1)
24126         dsci_inv = vbld_inv(i+1)/2.0
24127         dxi    = dc_norm(1,i)
24128         dyi    = dc_norm(2,i)
24129         dzi    = dc_norm(3,i)
24130         xi=(c(1,i)+c(1,i+1))/2.0
24131         yi=(c(2,i)+c(2,i+1))/2.0
24132         zi=(c(3,i)+c(3,i+1))/2.0
24133         xi=mod(xi,boxxsize)
24134          if (xi.lt.0) xi=xi+boxxsize
24135         yi=mod(yi,boxysize)
24136          if (yi.lt.0) yi=yi+boxysize
24137         zi=mod(zi,boxzsize)
24138          if (zi.lt.0) zi=zi+boxzsize
24139          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
24140            itypj= itype(j,2)
24141            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
24142             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
24143            xj=(c(1,j)+c(1,j+1))/2.0
24144            yj=(c(2,j)+c(2,j+1))/2.0
24145            zj=(c(3,j)+c(3,j+1))/2.0
24146            xj=dmod(xj,boxxsize)
24147            if (xj.lt.0) xj=xj+boxxsize
24148            yj=dmod(yj,boxysize)
24149            if (yj.lt.0) yj=yj+boxysize
24150            zj=dmod(zj,boxzsize)
24151            if (zj.lt.0) zj=zj+boxzsize
24152           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24153           xj_safe=xj
24154           yj_safe=yj
24155           zj_safe=zj
24156           subchap=0
24157           do xshift=-1,1
24158           do yshift=-1,1
24159           do zshift=-1,1
24160           xj=xj_safe+xshift*boxxsize
24161           yj=yj_safe+yshift*boxysize
24162           zj=zj_safe+zshift*boxzsize
24163           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24164           if(dist_temp.lt.dist_init) then
24165             dist_init=dist_temp
24166             xj_temp=xj
24167             yj_temp=yj
24168             zj_temp=zj
24169             subchap=1
24170           endif
24171           enddo
24172           enddo
24173           enddo
24174           if (subchap.eq.1) then
24175           xj=xj_temp-xi
24176           yj=yj_temp-yi
24177           zj=zj_temp-zi
24178           else
24179           xj=xj_safe-xi
24180           yj=yj_safe-yi
24181           zj=zj_safe-zi
24182           endif
24183           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24184           rij  = dsqrt(rrij)
24185           dxj = dc_norm( 1,j )
24186           dyj = dc_norm( 2,j )
24187           dzj = dc_norm( 3,j )
24188           dscj_inv = vbld_inv(j+1)/2.0
24189 ! Gay-berne var's
24190           sig0ij = sigma_peppho
24191 !          chi1=0.0d0
24192 !          chi2=0.0d0
24193           chi12  = chi1 * chi2
24194 !          chip1=0.0d0
24195 !          chip2=0.0d0
24196           chip12 = chip1 * chip2
24197 !          chis1 = 0.0d0
24198 !          chis2 = 0.0d0
24199           chis12 = chis1 * chis2
24200           sig1 = sigmap1_peppho
24201           sig2 = sigmap2_peppho
24202 !       write (*,*) "sig1 = ", sig1
24203 !       write (*,*) "sig1 = ", sig1
24204 !       write (*,*) "sig2 = ", sig2
24205 ! alpha factors from Fcav/Gcav
24206           alf1   = 0.0d0
24207           alf2   = 0.0d0
24208           alf12  = 0.0d0
24209           b1 = alphasur_peppho(1)
24210 !          b1=0.0d0
24211           b2 = alphasur_peppho(2)
24212           b3 = alphasur_peppho(3)
24213           b4 = alphasur_peppho(4)
24214           CALL sc_angular
24215        sqom1=om1*om1
24216        evdwij = 0.0d0
24217        ECL = 0.0d0
24218        Elj = 0.0d0
24219        Equad = 0.0d0
24220        Epol = 0.0d0
24221        Fcav=0.0d0
24222        eheadtail = 0.0d0
24223        dGCLdR=0.0d0
24224        dGCLdOM1 = 0.0d0
24225        dGCLdOM2 = 0.0d0
24226        dGCLdOM12 = 0.0d0
24227        dPOLdOM1 = 0.0d0
24228        dPOLdOM2 = 0.0d0
24229           Fcav = 0.0d0
24230           dFdR = 0.0d0
24231           dCAVdOM1  = 0.0d0
24232           dCAVdOM2  = 0.0d0
24233           dCAVdOM12 = 0.0d0
24234           rij_shift = rij
24235           fac       = rij_shift**expon
24236           c1        = fac  * fac * aa_peppho
24237 !          c1        = 0.0d0
24238           c2        = fac  * bb_peppho
24239 !          c2        = 0.0d0
24240           evdwij    =  c1 + c2
24241 ! Now cavity....................
24242        eagle = dsqrt(1.0/rij_shift)
24243        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
24244           bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
24245           botsq = bot * bot
24246           Fcav = top / bot
24247           dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
24248           dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
24249           dFdR = ((dtop * bot - top * dbot) / botsq)
24250        w1        = wqdip_peppho(1)
24251        w2        = wqdip_peppho(2)
24252 !       w1=0.0d0
24253 !       w2=0.0d0
24254 !       pis       = sig0head_scbase(itypi,itypj)
24255 !       eps_head   = epshead_scbase(itypi,itypj)
24256 !c!-------------------------------------------------------------------
24257
24258 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24259 !c!     &        +dhead(1,1,itypi,itypj))**2))
24260 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24261 !c!     &        +dhead(2,1,itypi,itypj))**2))
24262
24263 !c!-------------------------------------------------------------------
24264 !c! ecl
24265        sparrow  = w1  *  om1
24266        hawk     = w2 *  (1.0d0 - sqom1)
24267        Ecl = sparrow * rij_shift**2.0d0 &
24268            - hawk    * rij_shift**4.0d0
24269 !c!-------------------------------------------------------------------
24270 !c! derivative of ecl is Gcl
24271 !c! dF/dr part
24272 !       rij_shift=5.0
24273        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
24274                 + 4.0d0 * hawk    * rij_shift**5.0d0
24275 !c! dF/dom1
24276        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
24277 !c! dF/dom2
24278        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
24279        eom1  =    dGCLdOM1+dGCLdOM2
24280        eom2  =    0.0
24281
24282           fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
24283 !          fac=0.0
24284           gg(1) =  fac*xj*rij
24285           gg(2) =  fac*yj*rij
24286           gg(3) =  fac*zj*rij
24287          do k=1,3
24288          gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
24289          gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
24290          gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
24291          gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
24292          gg(k)=0.0
24293          enddo
24294
24295       DO k = 1, 3
24296         dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
24297         dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
24298         gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
24299         gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
24300 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24301         gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
24302 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24303         gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
24304                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24305         gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
24306                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24307         enddo
24308        epeppho=epeppho+evdwij+Fcav+ECL
24309 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
24310        enddo
24311        enddo
24312       end subroutine eprot_pep_phosphate
24313 !!!!!!!!!!!!!!!!-------------------------------------------------------------
24314       subroutine emomo(evdw)
24315       use calc_data
24316       use comm_momo
24317 !      implicit real*8 (a-h,o-z)
24318 !      include 'DIMENSIONS'
24319 !      include 'COMMON.GEO'
24320 !      include 'COMMON.VAR'
24321 !      include 'COMMON.LOCAL'
24322 !      include 'COMMON.CHAIN'
24323 !      include 'COMMON.DERIV'
24324 !      include 'COMMON.NAMES'
24325 !      include 'COMMON.INTERACT'
24326 !      include 'COMMON.IOUNITS'
24327 !      include 'COMMON.CALC'
24328 !      include 'COMMON.CONTROL'
24329 !      include 'COMMON.SBRIDGE'
24330       logical :: lprn
24331 !el local variables
24332       integer :: iint,itypi1,subchap,isel
24333       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
24334       real(kind=8) :: evdw
24335       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24336                     dist_temp, dist_init,ssgradlipi,ssgradlipj, &
24337                     sslipi,sslipj,faclip,alpha_sco
24338       integer :: ii
24339       real(kind=8) :: fracinbuf
24340        real (kind=8) :: escpho
24341        real (kind=8),dimension(4):: ener
24342        real(kind=8) :: b1,b2,egb
24343        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
24344         Lambf,&
24345         Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
24346         dFdOM2,dFdL,dFdOM12,&
24347         federmaus,&
24348         d1i,d1j
24349 !       real(kind=8),dimension(3,2)::erhead_tail
24350 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
24351        real(kind=8) ::  facd4, adler, Fgb, facd3
24352        integer troll,jj,istate
24353        real (kind=8) :: dcosom1(3),dcosom2(3)
24354        eps_out=80.0d0
24355        sss_ele_cut=1.0d0
24356 !       print *,"EVDW KURW",evdw,nres
24357       do i=iatsc_s,iatsc_e
24358 !        print *,"I am in EVDW",i
24359         itypi=iabs(itype(i,1))
24360 !        if (i.ne.47) cycle
24361         if (itypi.eq.ntyp1) cycle
24362         itypi1=iabs(itype(i+1,1))
24363         xi=c(1,nres+i)
24364         yi=c(2,nres+i)
24365         zi=c(3,nres+i)
24366           xi=dmod(xi,boxxsize)
24367           if (xi.lt.0) xi=xi+boxxsize
24368           yi=dmod(yi,boxysize)
24369           if (yi.lt.0) yi=yi+boxysize
24370           zi=dmod(zi,boxzsize)
24371           if (zi.lt.0) zi=zi+boxzsize
24372
24373        if ((zi.gt.bordlipbot)  &
24374         .and.(zi.lt.bordliptop)) then
24375 !C the energy transfer exist
24376         if (zi.lt.buflipbot) then
24377 !C what fraction I am in
24378          fracinbuf=1.0d0-  &
24379               ((zi-bordlipbot)/lipbufthick)
24380 !C lipbufthick is thickenes of lipid buffore
24381          sslipi=sscalelip(fracinbuf)
24382          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
24383         elseif (zi.gt.bufliptop) then
24384          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
24385          sslipi=sscalelip(fracinbuf)
24386          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
24387         else
24388          sslipi=1.0d0
24389          ssgradlipi=0.0
24390         endif
24391        else
24392          sslipi=0.0d0
24393          ssgradlipi=0.0
24394        endif
24395 !       print *, sslipi,ssgradlipi
24396         dxi=dc_norm(1,nres+i)
24397         dyi=dc_norm(2,nres+i)
24398         dzi=dc_norm(3,nres+i)
24399 !        dsci_inv=dsc_inv(itypi)
24400         dsci_inv=vbld_inv(i+nres)
24401 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
24402 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
24403 !
24404 ! Calculate SC interaction energy.
24405 !
24406         do iint=1,nint_gr(i)
24407           do j=istart(i,iint),iend(i,iint)
24408 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
24409             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
24410               call dyn_ssbond_ene(i,j,evdwij)
24411               evdw=evdw+evdwij
24412               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
24413                               'evdw',i,j,evdwij,' ss'
24414 !              if (energy_dec) write (iout,*) &
24415 !                              'evdw',i,j,evdwij,' ss'
24416              do k=j+1,iend(i,iint)
24417 !C search over all next residues
24418               if (dyn_ss_mask(k)) then
24419 !C check if they are cysteins
24420 !C              write(iout,*) 'k=',k
24421
24422 !c              write(iout,*) "PRZED TRI", evdwij
24423 !               evdwij_przed_tri=evdwij
24424               call triple_ssbond_ene(i,j,k,evdwij)
24425 !c               if(evdwij_przed_tri.ne.evdwij) then
24426 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
24427 !c               endif
24428
24429 !c              write(iout,*) "PO TRI", evdwij
24430 !C call the energy function that removes the artifical triple disulfide
24431 !C bond the soubroutine is located in ssMD.F
24432               evdw=evdw+evdwij
24433               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
24434                             'evdw',i,j,evdwij,'tss'
24435               endif!dyn_ss_mask(k)
24436              enddo! k
24437             ELSE
24438 !el            ind=ind+1
24439             itypj=iabs(itype(j,1))
24440             if (itypj.eq.ntyp1) cycle
24441              CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
24442
24443 !             if (j.ne.78) cycle
24444 !            dscj_inv=dsc_inv(itypj)
24445             dscj_inv=vbld_inv(j+nres)
24446            xj=c(1,j+nres)
24447            yj=c(2,j+nres)
24448            zj=c(3,j+nres)
24449            xj=dmod(xj,boxxsize)
24450            if (xj.lt.0) xj=xj+boxxsize
24451            yj=dmod(yj,boxysize)
24452            if (yj.lt.0) yj=yj+boxysize
24453            zj=dmod(zj,boxzsize)
24454            if (zj.lt.0) zj=zj+boxzsize
24455           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24456           xj_safe=xj
24457           yj_safe=yj
24458           zj_safe=zj
24459           subchap=0
24460
24461           do xshift=-1,1
24462           do yshift=-1,1
24463           do zshift=-1,1
24464           xj=xj_safe+xshift*boxxsize
24465           yj=yj_safe+yshift*boxysize
24466           zj=zj_safe+zshift*boxzsize
24467           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24468           if(dist_temp.lt.dist_init) then
24469             dist_init=dist_temp
24470             xj_temp=xj
24471             yj_temp=yj
24472             zj_temp=zj
24473             subchap=1
24474           endif
24475           enddo
24476           enddo
24477           enddo
24478           if (subchap.eq.1) then
24479           xj=xj_temp-xi
24480           yj=yj_temp-yi
24481           zj=zj_temp-zi
24482           else
24483           xj=xj_safe-xi
24484           yj=yj_safe-yi
24485           zj=zj_safe-zi
24486           endif
24487           dxj = dc_norm( 1, nres+j )
24488           dyj = dc_norm( 2, nres+j )
24489           dzj = dc_norm( 3, nres+j )
24490 !          print *,i,j,itypi,itypj
24491 !          d1i=0.0d0
24492 !          d1j=0.0d0
24493 !          BetaT = 1.0d0 / (298.0d0 * Rb)
24494 ! Gay-berne var's
24495 !1!          sig0ij = sigma_scsc( itypi,itypj )
24496 !          chi1=0.0d0
24497 !          chi2=0.0d0
24498 !          chip1=0.0d0
24499 !          chip2=0.0d0
24500 ! not used by momo potential, but needed by sc_angular which is shared
24501 ! by all energy_potential subroutines
24502           alf1   = 0.0d0
24503           alf2   = 0.0d0
24504           alf12  = 0.0d0
24505           a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
24506 !       a12sq = a12sq * a12sq
24507 ! charge of amino acid itypi is...
24508           chis1 = chis(itypi,itypj)
24509           chis2 = chis(itypj,itypi)
24510           chis12 = chis1 * chis2
24511           sig1 = sigmap1(itypi,itypj)
24512           sig2 = sigmap2(itypi,itypj)
24513 !       write (*,*) "sig1 = ", sig1
24514 !          chis1=0.0
24515 !          chis2=0.0
24516 !                    chis12 = chis1 * chis2
24517 !          sig1=0.0
24518 !          sig2=0.0
24519 !       write (*,*) "sig2 = ", sig2
24520 ! alpha factors from Fcav/Gcav
24521           b1cav = alphasur(1,itypi,itypj)
24522 !          b1cav=0.0d0
24523           b2cav = alphasur(2,itypi,itypj)
24524           b3cav = alphasur(3,itypi,itypj)
24525           b4cav = alphasur(4,itypi,itypj)
24526 ! used to determine whether we want to do quadrupole calculations
24527        eps_in = epsintab(itypi,itypj)
24528        if (eps_in.eq.0.0) eps_in=1.0
24529
24530        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24531        Rtail = 0.0d0
24532 !       dtail(1,itypi,itypj)=0.0
24533 !       dtail(2,itypi,itypj)=0.0
24534
24535        DO k = 1, 3
24536         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
24537         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
24538        END DO
24539 !c! tail distances will be themselves usefull elswhere
24540 !c1 (in Gcav, for example)
24541        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
24542        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
24543        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
24544        Rtail = dsqrt( &
24545           (Rtail_distance(1)*Rtail_distance(1)) &
24546         + (Rtail_distance(2)*Rtail_distance(2)) &
24547         + (Rtail_distance(3)*Rtail_distance(3)))
24548
24549 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24550 !-------------------------------------------------------------------
24551 ! tail location and distance calculations
24552        d1 = dhead(1, 1, itypi, itypj)
24553        d2 = dhead(2, 1, itypi, itypj)
24554
24555        DO k = 1,3
24556 ! location of polar head is computed by taking hydrophobic centre
24557 ! and moving by a d1 * dc_norm vector
24558 ! see unres publications for very informative images
24559         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
24560         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
24561 ! distance
24562 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24563 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24564         Rhead_distance(k) = chead(k,2) - chead(k,1)
24565        END DO
24566 ! pitagoras (root of sum of squares)
24567        Rhead = dsqrt( &
24568           (Rhead_distance(1)*Rhead_distance(1)) &
24569         + (Rhead_distance(2)*Rhead_distance(2)) &
24570         + (Rhead_distance(3)*Rhead_distance(3)))
24571 !-------------------------------------------------------------------
24572 ! zero everything that should be zero'ed
24573        evdwij = 0.0d0
24574        ECL = 0.0d0
24575        Elj = 0.0d0
24576        Equad = 0.0d0
24577        Epol = 0.0d0
24578        Fcav=0.0d0
24579        eheadtail = 0.0d0
24580        dGCLdOM1 = 0.0d0
24581        dGCLdOM2 = 0.0d0
24582        dGCLdOM12 = 0.0d0
24583        dPOLdOM1 = 0.0d0
24584        dPOLdOM2 = 0.0d0
24585           Fcav = 0.0d0
24586           dFdR = 0.0d0
24587           dCAVdOM1  = 0.0d0
24588           dCAVdOM2  = 0.0d0
24589           dCAVdOM12 = 0.0d0
24590           dscj_inv = vbld_inv(j+nres)
24591 !          print *,i,j,dscj_inv,dsci_inv
24592 ! rij holds 1/(distance of Calpha atoms)
24593           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24594           rij  = dsqrt(rrij)
24595 !----------------------------
24596           CALL sc_angular
24597 ! this should be in elgrad_init but om's are calculated by sc_angular
24598 ! which in turn is used by older potentials
24599 ! om = omega, sqom = om^2
24600           sqom1  = om1 * om1
24601           sqom2  = om2 * om2
24602           sqom12 = om12 * om12
24603
24604 ! now we calculate EGB - Gey-Berne
24605 ! It will be summed up in evdwij and saved in evdw
24606           sigsq     = 1.0D0  / sigsq
24607           sig       = sig0ij * dsqrt(sigsq)
24608 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24609           rij_shift = Rtail - sig + sig0ij
24610           IF (rij_shift.le.0.0D0) THEN
24611            evdw = 1.0D20
24612            RETURN
24613           END IF
24614           sigder = -sig * sigsq
24615           rij_shift = 1.0D0 / rij_shift
24616           fac       = rij_shift**expon
24617           c1        = fac  * fac * aa_aq(itypi,itypj)
24618 !          print *,"ADAM",aa_aq(itypi,itypj)
24619
24620 !          c1        = 0.0d0
24621           c2        = fac  * bb_aq(itypi,itypj)
24622 !          c2        = 0.0d0
24623           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24624           eps2der   = eps3rt * evdwij
24625           eps3der   = eps2rt * evdwij
24626 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24627           evdwij    = eps2rt * eps3rt * evdwij
24628 !#ifdef TSCSC
24629 !          IF (bb_aq(itypi,itypj).gt.0) THEN
24630 !           evdw_p = evdw_p + evdwij
24631 !          ELSE
24632 !           evdw_m = evdw_m + evdwij
24633 !          END IF
24634 !#else
24635           evdw = evdw  &
24636               + evdwij
24637 !#endif
24638
24639           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24640           fac    = -expon * (c1 + evdwij) * rij_shift
24641           sigder = fac * sigder
24642 !          fac    = rij * fac
24643 ! Calculate distance derivative
24644           gg(1) =  fac
24645           gg(2) =  fac
24646           gg(3) =  fac
24647 !          if (b2.gt.0.0) then
24648           fac = chis1 * sqom1 + chis2 * sqom2 &
24649           - 2.0d0 * chis12 * om1 * om2 * om12
24650 ! we will use pom later in Gcav, so dont mess with it!
24651           pom = 1.0d0 - chis1 * chis2 * sqom12
24652           Lambf = (1.0d0 - (fac / pom))
24653 !          print *,"fac,pom",fac,pom,Lambf
24654           Lambf = dsqrt(Lambf)
24655           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24656 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
24657 !       write (*,*) "sparrow = ", sparrow
24658           Chif = Rtail * sparrow
24659 !           print *,"rij,sparrow",rij , sparrow
24660           ChiLambf = Chif * Lambf
24661           eagle = dsqrt(ChiLambf)
24662           bat = ChiLambf ** 11.0d0
24663           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
24664           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
24665           botsq = bot * bot
24666 !          print *,top,bot,"bot,top",ChiLambf,Chif
24667           Fcav = top / bot
24668
24669        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
24670        dbot = 12.0d0 * b4cav * bat * Lambf
24671        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24672
24673           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
24674           dbot = 12.0d0 * b4cav * bat * Chif
24675           eagle = Lambf * pom
24676           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24677           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24678           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24679               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24680
24681           dFdL = ((dtop * bot - top * dbot) / botsq)
24682 !       dFdL = 0.0d0
24683           dCAVdOM1  = dFdL * ( dFdOM1 )
24684           dCAVdOM2  = dFdL * ( dFdOM2 )
24685           dCAVdOM12 = dFdL * ( dFdOM12 )
24686
24687        DO k= 1, 3
24688         ertail(k) = Rtail_distance(k)/Rtail
24689        END DO
24690        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
24691        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
24692        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
24693        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24694        DO k = 1, 3
24695 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24696 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24697         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24698         gvdwx(k,i) = gvdwx(k,i) &
24699                   - (( dFdR + gg(k) ) * pom)
24700 !c!     &             - ( dFdR * pom )
24701         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24702         gvdwx(k,j) = gvdwx(k,j)   &
24703                   + (( dFdR + gg(k) ) * pom)
24704 !c!     &             + ( dFdR * pom )
24705
24706         gvdwc(k,i) = gvdwc(k,i)  &
24707                   - (( dFdR + gg(k) ) * ertail(k))
24708 !c!     &             - ( dFdR * ertail(k))
24709
24710         gvdwc(k,j) = gvdwc(k,j) &
24711                   + (( dFdR + gg(k) ) * ertail(k))
24712 !c!     &             + ( dFdR * ertail(k))
24713
24714         gg(k) = 0.0d0
24715 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24716 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24717       END DO
24718
24719
24720 !c! Compute head-head and head-tail energies for each state
24721
24722           isel = iabs(Qi) + iabs(Qj)
24723 !          isel=0
24724           IF (isel.eq.0) THEN
24725 !c! No charges - do nothing
24726            eheadtail = 0.0d0
24727
24728           ELSE IF (isel.eq.4) THEN
24729 !c! Calculate dipole-dipole interactions
24730            CALL edd(ecl)
24731            eheadtail = ECL
24732 !           eheadtail = 0.0d0
24733
24734           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
24735 !c! Charge-nonpolar interactions
24736            CALL eqn(epol)
24737            eheadtail = epol
24738 !           eheadtail = 0.0d0
24739
24740           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
24741 !c! Nonpolar-charge interactions
24742            CALL enq(epol)
24743            eheadtail = epol
24744 !           eheadtail = 0.0d0
24745
24746           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
24747 !c! Charge-dipole interactions
24748            CALL eqd(ecl, elj, epol)
24749            eheadtail = ECL + elj + epol
24750 !           eheadtail = 0.0d0
24751
24752           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
24753 !c! Dipole-charge interactions
24754            CALL edq(ecl, elj, epol)
24755           eheadtail = ECL + elj + epol
24756 !           eheadtail = 0.0d0
24757
24758           ELSE IF ((isel.eq.2.and.   &
24759                iabs(Qi).eq.1).and.  &
24760                nstate(itypi,itypj).eq.1) THEN
24761 !c! Same charge-charge interaction ( +/+ or -/- )
24762            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
24763            eheadtail = ECL + Egb + Epol + Fisocav + Elj
24764 !           eheadtail = 0.0d0
24765
24766           ELSE IF ((isel.eq.2.and.  &
24767                iabs(Qi).eq.1).and. &
24768                nstate(itypi,itypj).ne.1) THEN
24769 !c! Different charge-charge interaction ( +/- or -/+ )
24770            CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
24771           END IF
24772        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
24773       evdw = evdw  + Fcav + eheadtail
24774
24775        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
24776         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
24777         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
24778         Equad,evdwij+Fcav+eheadtail,evdw
24779 !       evdw = evdw  + Fcav  + eheadtail
24780
24781         iF (nstate(itypi,itypj).eq.1) THEN
24782         CALL sc_grad
24783        END IF
24784 !c!-------------------------------------------------------------------
24785 !c! NAPISY KONCOWE
24786          END DO   ! j
24787         END DO    ! iint
24788        END DO     ! i
24789 !c      write (iout,*) "Number of loop steps in EGB:",ind
24790 !c      energy_dec=.false.
24791 !              print *,"EVDW KURW",evdw,nres
24792
24793        RETURN
24794       END SUBROUTINE emomo
24795 !C------------------------------------------------------------------------------------
24796       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
24797       use calc_data
24798       use comm_momo
24799        real (kind=8) ::  facd3, facd4, federmaus, adler,&
24800          Ecl,Egb,Epol,Fisocav,Elj,Fgb
24801 !       integer :: k
24802 !c! Epol and Gpol analytical parameters
24803        alphapol1 = alphapol(itypi,itypj)
24804        alphapol2 = alphapol(itypj,itypi)
24805 !c! Fisocav and Gisocav analytical parameters
24806        al1  = alphiso(1,itypi,itypj)
24807        al2  = alphiso(2,itypi,itypj)
24808        al3  = alphiso(3,itypi,itypj)
24809        al4  = alphiso(4,itypi,itypj)
24810        csig = (1.0d0  &
24811            / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
24812            + sigiso2(itypi,itypj)**2.0d0))
24813 !c!
24814        pis  = sig0head(itypi,itypj)
24815        eps_head = epshead(itypi,itypj)
24816        Rhead_sq = Rhead * Rhead
24817 !c! R1 - distance between head of ith side chain and tail of jth sidechain
24818 !c! R2 - distance between head of jth side chain and tail of ith sidechain
24819        R1 = 0.0d0
24820        R2 = 0.0d0
24821        DO k = 1, 3
24822 !c! Calculate head-to-tail distances needed by Epol
24823         R1=R1+(ctail(k,2)-chead(k,1))**2
24824         R2=R2+(chead(k,2)-ctail(k,1))**2
24825        END DO
24826 !c! Pitagoras
24827        R1 = dsqrt(R1)
24828        R2 = dsqrt(R2)
24829
24830 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24831 !c!     &        +dhead(1,1,itypi,itypj))**2))
24832 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24833 !c!     &        +dhead(2,1,itypi,itypj))**2))
24834
24835 !c!-------------------------------------------------------------------
24836 !c! Coulomb electrostatic interaction
24837        Ecl = (332.0d0 * Qij) / Rhead
24838 !c! derivative of Ecl is Gcl...
24839        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
24840        dGCLdOM1 = 0.0d0
24841        dGCLdOM2 = 0.0d0
24842        dGCLdOM12 = 0.0d0
24843        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
24844        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
24845        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
24846 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
24847 !c! Derivative of Egb is Ggb...
24848        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
24849        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
24850        dGGBdR = dGGBdFGB * dFGBdR
24851 !c!-------------------------------------------------------------------
24852 !c! Fisocav - isotropic cavity creation term
24853 !c! or "how much energy it costs to put charged head in water"
24854        pom = Rhead * csig
24855        top = al1 * (dsqrt(pom) + al2 * pom - al3)
24856        bot = (1.0d0 + al4 * pom**12.0d0)
24857        botsq = bot * bot
24858        FisoCav = top / bot
24859 !      write (*,*) "Rhead = ",Rhead
24860 !      write (*,*) "csig = ",csig
24861 !      write (*,*) "pom = ",pom
24862 !      write (*,*) "al1 = ",al1
24863 !      write (*,*) "al2 = ",al2
24864 !      write (*,*) "al3 = ",al3
24865 !      write (*,*) "al4 = ",al4
24866 !        write (*,*) "top = ",top
24867 !        write (*,*) "bot = ",bot
24868 !c! Derivative of Fisocav is GCV...
24869        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
24870        dbot = 12.0d0 * al4 * pom ** 11.0d0
24871        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
24872 !c!-------------------------------------------------------------------
24873 !c! Epol
24874 !c! Polarization energy - charged heads polarize hydrophobic "neck"
24875        MomoFac1 = (1.0d0 - chi1 * sqom2)
24876        MomoFac2 = (1.0d0 - chi2 * sqom1)
24877        RR1  = ( R1 * R1 ) / MomoFac1
24878        RR2  = ( R2 * R2 ) / MomoFac2
24879        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24880        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
24881        fgb1 = sqrt( RR1 + a12sq * ee1 )
24882        fgb2 = sqrt( RR2 + a12sq * ee2 )
24883        epol = 332.0d0 * eps_inout_fac * ( &
24884       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
24885 !c!       epol = 0.0d0
24886        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
24887                / (fgb1 ** 5.0d0)
24888        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
24889                / (fgb2 ** 5.0d0)
24890        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
24891              / ( 2.0d0 * fgb1 )
24892        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
24893              / ( 2.0d0 * fgb2 )
24894        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
24895                 * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
24896        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
24897                 * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
24898        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24899 !c!       dPOLdR1 = 0.0d0
24900        dPOLdR2 = dPOLdFGB2 * dFGBdR2
24901 !c!       dPOLdR2 = 0.0d0
24902        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
24903 !c!       dPOLdOM1 = 0.0d0
24904        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
24905 !c!       dPOLdOM2 = 0.0d0
24906 !c!-------------------------------------------------------------------
24907 !c! Elj
24908 !c! Lennard-Jones 6-12 interaction between heads
24909        pom = (pis / Rhead)**6.0d0
24910        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
24911 !c! derivative of Elj is Glj
24912        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
24913              +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
24914 !c!-------------------------------------------------------------------
24915 !c! Return the results
24916 !c! These things do the dRdX derivatives, that is
24917 !c! allow us to change what we see from function that changes with
24918 !c! distance to function that changes with LOCATION (of the interaction
24919 !c! site)
24920        DO k = 1, 3
24921         erhead(k) = Rhead_distance(k)/Rhead
24922         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
24923         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
24924        END DO
24925
24926        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24927        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24928        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24929        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
24930        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
24931        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
24932        facd1 = d1 * vbld_inv(i+nres)
24933        facd2 = d2 * vbld_inv(j+nres)
24934        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
24935        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24936
24937 !c! Now we add appropriate partial derivatives (one in each dimension)
24938        DO k = 1, 3
24939         hawk   = (erhead_tail(k,1) + &
24940         facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
24941         condor = (erhead_tail(k,2) + &
24942         facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
24943
24944         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24945         gvdwx(k,i) = gvdwx(k,i) &
24946                   - dGCLdR * pom&
24947                   - dGGBdR * pom&
24948                   - dGCVdR * pom&
24949                   - dPOLdR1 * hawk&
24950                   - dPOLdR2 * (erhead_tail(k,2)&
24951       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
24952                   - dGLJdR * pom
24953
24954         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24955         gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
24956                    + dGGBdR * pom+ dGCVdR * pom&
24957                   + dPOLdR1 * (erhead_tail(k,1)&
24958       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
24959                   + dPOLdR2 * condor + dGLJdR * pom
24960
24961         gvdwc(k,i) = gvdwc(k,i)  &
24962                   - dGCLdR * erhead(k)&
24963                   - dGGBdR * erhead(k)&
24964                   - dGCVdR * erhead(k)&
24965                   - dPOLdR1 * erhead_tail(k,1)&
24966                   - dPOLdR2 * erhead_tail(k,2)&
24967                   - dGLJdR * erhead(k)
24968
24969         gvdwc(k,j) = gvdwc(k,j)         &
24970                   + dGCLdR * erhead(k) &
24971                   + dGGBdR * erhead(k) &
24972                   + dGCVdR * erhead(k) &
24973                   + dPOLdR1 * erhead_tail(k,1) &
24974                   + dPOLdR2 * erhead_tail(k,2)&
24975                   + dGLJdR * erhead(k)
24976
24977        END DO
24978        RETURN
24979       END SUBROUTINE eqq
24980 !c!-------------------------------------------------------------------
24981       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
24982       use comm_momo
24983       use calc_data
24984
24985        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
24986        double precision ener(4)
24987        double precision dcosom1(3),dcosom2(3)
24988 !c! used in Epol derivatives
24989        double precision facd3, facd4
24990        double precision federmaus, adler
24991        integer istate,ii,jj
24992        real (kind=8) :: Fgb
24993 !       print *,"CALLING EQUAD"
24994 !c! Epol and Gpol analytical parameters
24995        alphapol1 = alphapol(itypi,itypj)
24996        alphapol2 = alphapol(itypj,itypi)
24997 !c! Fisocav and Gisocav analytical parameters
24998        al1  = alphiso(1,itypi,itypj)
24999        al2  = alphiso(2,itypi,itypj)
25000        al3  = alphiso(3,itypi,itypj)
25001        al4  = alphiso(4,itypi,itypj)
25002        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
25003             + sigiso2(itypi,itypj)**2.0d0))
25004 !c!
25005        w1   = wqdip(1,itypi,itypj)
25006        w2   = wqdip(2,itypi,itypj)
25007        pis  = sig0head(itypi,itypj)
25008        eps_head = epshead(itypi,itypj)
25009 !c! First things first:
25010 !c! We need to do sc_grad's job with GB and Fcav
25011        eom1  = eps2der * eps2rt_om1 &
25012              - 2.0D0 * alf1 * eps3der&
25013              + sigder * sigsq_om1&
25014              + dCAVdOM1
25015        eom2  = eps2der * eps2rt_om2 &
25016              + 2.0D0 * alf2 * eps3der&
25017              + sigder * sigsq_om2&
25018              + dCAVdOM2
25019        eom12 =  evdwij  * eps1_om12 &
25020              + eps2der * eps2rt_om12 &
25021              - 2.0D0 * alf12 * eps3der&
25022              + sigder *sigsq_om12&
25023              + dCAVdOM12
25024 !c! now some magical transformations to project gradient into
25025 !c! three cartesian vectors
25026        DO k = 1, 3
25027         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25028         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25029         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
25030 !c! this acts on hydrophobic center of interaction
25031         gvdwx(k,i)= gvdwx(k,i) - gg(k) &
25032                   + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
25033                   + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25034         gvdwx(k,j)= gvdwx(k,j) + gg(k) &
25035                   + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
25036                   + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25037 !c! this acts on Calpha
25038         gvdwc(k,i)=gvdwc(k,i)-gg(k)
25039         gvdwc(k,j)=gvdwc(k,j)+gg(k)
25040        END DO
25041 !c! sc_grad is done, now we will compute
25042        eheadtail = 0.0d0
25043        eom1 = 0.0d0
25044        eom2 = 0.0d0
25045        eom12 = 0.0d0
25046        DO istate = 1, nstate(itypi,itypj)
25047 !c*************************************************************
25048         IF (istate.ne.1) THEN
25049          IF (istate.lt.3) THEN
25050           ii = 1
25051          ELSE
25052           ii = 2
25053          END IF
25054         jj = istate/ii
25055         d1 = dhead(1,ii,itypi,itypj)
25056         d2 = dhead(2,jj,itypi,itypj)
25057         DO k = 1,3
25058          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25059          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25060          Rhead_distance(k) = chead(k,2) - chead(k,1)
25061         END DO
25062 !c! pitagoras (root of sum of squares)
25063         Rhead = dsqrt( &
25064                (Rhead_distance(1)*Rhead_distance(1))  &
25065              + (Rhead_distance(2)*Rhead_distance(2))  &
25066              + (Rhead_distance(3)*Rhead_distance(3)))
25067         END IF
25068         Rhead_sq = Rhead * Rhead
25069
25070 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25071 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25072         R1 = 0.0d0
25073         R2 = 0.0d0
25074         DO k = 1, 3
25075 !c! Calculate head-to-tail distances
25076          R1=R1+(ctail(k,2)-chead(k,1))**2
25077          R2=R2+(chead(k,2)-ctail(k,1))**2
25078         END DO
25079 !c! Pitagoras
25080         R1 = dsqrt(R1)
25081         R2 = dsqrt(R2)
25082         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
25083 !c!        Ecl = 0.0d0
25084 !c!        write (*,*) "Ecl = ", Ecl
25085 !c! derivative of Ecl is Gcl...
25086         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
25087 !c!        dGCLdR = 0.0d0
25088         dGCLdOM1 = 0.0d0
25089         dGCLdOM2 = 0.0d0
25090         dGCLdOM12 = 0.0d0
25091 !c!-------------------------------------------------------------------
25092 !c! Generalised Born Solvent Polarization
25093         ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
25094         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
25095         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
25096 !c!        Egb = 0.0d0
25097 !c!      write (*,*) "a1*a2 = ", a12sq
25098 !c!      write (*,*) "Rhead = ", Rhead
25099 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
25100 !c!      write (*,*) "ee = ", ee
25101 !c!      write (*,*) "Fgb = ", Fgb
25102 !c!      write (*,*) "fac = ", eps_inout_fac
25103 !c!      write (*,*) "Qij = ", Qij
25104 !c!      write (*,*) "Egb = ", Egb
25105 !c! Derivative of Egb is Ggb...
25106 !c! dFGBdR is used by Quad's later...
25107         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
25108         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
25109                / ( 2.0d0 * Fgb )
25110         dGGBdR = dGGBdFGB * dFGBdR
25111 !c!        dGGBdR = 0.0d0
25112 !c!-------------------------------------------------------------------
25113 !c! Fisocav - isotropic cavity creation term
25114         pom = Rhead * csig
25115         top = al1 * (dsqrt(pom) + al2 * pom - al3)
25116         bot = (1.0d0 + al4 * pom**12.0d0)
25117         botsq = bot * bot
25118         FisoCav = top / bot
25119         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
25120         dbot = 12.0d0 * al4 * pom ** 11.0d0
25121         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
25122 !c!        dGCVdR = 0.0d0
25123 !c!-------------------------------------------------------------------
25124 !c! Polarization energy
25125 !c! Epol
25126         MomoFac1 = (1.0d0 - chi1 * sqom2)
25127         MomoFac2 = (1.0d0 - chi2 * sqom1)
25128         RR1  = ( R1 * R1 ) / MomoFac1
25129         RR2  = ( R2 * R2 ) / MomoFac2
25130         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25131         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
25132         fgb1 = sqrt( RR1 + a12sq * ee1 )
25133         fgb2 = sqrt( RR2 + a12sq * ee2 )
25134         epol = 332.0d0 * eps_inout_fac * (&
25135         (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
25136 !c!        epol = 0.0d0
25137 !c! derivative of Epol is Gpol...
25138         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
25139                   / (fgb1 ** 5.0d0)
25140         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
25141                   / (fgb2 ** 5.0d0)
25142         dFGBdR1 = ( (R1 / MomoFac1) &
25143                 * ( 2.0d0 - (0.5d0 * ee1) ) )&
25144                 / ( 2.0d0 * fgb1 )
25145         dFGBdR2 = ( (R2 / MomoFac2) &
25146                 * ( 2.0d0 - (0.5d0 * ee2) ) ) &
25147                 / ( 2.0d0 * fgb2 )
25148         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25149                  * ( 2.0d0 - 0.5d0 * ee1) ) &
25150                  / ( 2.0d0 * fgb1 )
25151         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
25152                  * ( 2.0d0 - 0.5d0 * ee2) ) &
25153                  / ( 2.0d0 * fgb2 )
25154         dPOLdR1 = dPOLdFGB1 * dFGBdR1
25155 !c!        dPOLdR1 = 0.0d0
25156         dPOLdR2 = dPOLdFGB2 * dFGBdR2
25157 !c!        dPOLdR2 = 0.0d0
25158         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25159 !c!        dPOLdOM1 = 0.0d0
25160         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25161         pom = (pis / Rhead)**6.0d0
25162         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25163 !c!        Elj = 0.0d0
25164 !c! derivative of Elj is Glj
25165         dGLJdR = 4.0d0 * eps_head &
25166             * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
25167             +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25168 !c!        dGLJdR = 0.0d0
25169 !c!-------------------------------------------------------------------
25170 !c! Equad
25171        IF (Wqd.ne.0.0d0) THEN
25172         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
25173              - 37.5d0  * ( sqom1 + sqom2 ) &
25174              + 157.5d0 * ( sqom1 * sqom2 ) &
25175              - 45.0d0  * om1*om2*om12
25176         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
25177         Equad = fac * Beta1
25178 !c!        Equad = 0.0d0
25179 !c! derivative of Equad...
25180         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
25181 !c!        dQUADdR = 0.0d0
25182         dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
25183 !c!        dQUADdOM1 = 0.0d0
25184         dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
25185 !c!        dQUADdOM2 = 0.0d0
25186         dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
25187        ELSE
25188          Beta1 = 0.0d0
25189          Equad = 0.0d0
25190         END IF
25191 !c!-------------------------------------------------------------------
25192 !c! Return the results
25193 !c! Angular stuff
25194         eom1 = dPOLdOM1 + dQUADdOM1
25195         eom2 = dPOLdOM2 + dQUADdOM2
25196         eom12 = dQUADdOM12
25197 !c! now some magical transformations to project gradient into
25198 !c! three cartesian vectors
25199         DO k = 1, 3
25200          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25201          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25202          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
25203         END DO
25204 !c! Radial stuff
25205         DO k = 1, 3
25206          erhead(k) = Rhead_distance(k)/Rhead
25207          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25208          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25209         END DO
25210         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25211         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25212         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25213         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25214         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25215         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25216         facd1 = d1 * vbld_inv(i+nres)
25217         facd2 = d2 * vbld_inv(j+nres)
25218         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25219         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25220         DO k = 1, 3
25221          hawk   = erhead_tail(k,1) + &
25222          facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
25223          condor = erhead_tail(k,2) + &
25224          facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
25225
25226          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25227 !c! this acts on hydrophobic center of interaction
25228          gheadtail(k,1,1) = gheadtail(k,1,1) &
25229                          - dGCLdR * pom &
25230                          - dGGBdR * pom &
25231                          - dGCVdR * pom &
25232                          - dPOLdR1 * hawk &
25233                          - dPOLdR2 * (erhead_tail(k,2) &
25234       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
25235                          - dGLJdR * pom &
25236                          - dQUADdR * pom&
25237                          - tuna(k) &
25238                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
25239                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25240
25241          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25242 !c! this acts on hydrophobic center of interaction
25243          gheadtail(k,2,1) = gheadtail(k,2,1)  &
25244                          + dGCLdR * pom      &
25245                          + dGGBdR * pom      &
25246                          + dGCVdR * pom      &
25247                          + dPOLdR1 * (erhead_tail(k,1) &
25248       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
25249                          + dPOLdR2 * condor &
25250                          + dGLJdR * pom &
25251                          + dQUADdR * pom &
25252                          + tuna(k) &
25253                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25254                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25255
25256 !c! this acts on Calpha
25257          gheadtail(k,3,1) = gheadtail(k,3,1)  &
25258                          - dGCLdR * erhead(k)&
25259                          - dGGBdR * erhead(k)&
25260                          - dGCVdR * erhead(k)&
25261                          - dPOLdR1 * erhead_tail(k,1)&
25262                          - dPOLdR2 * erhead_tail(k,2)&
25263                          - dGLJdR * erhead(k) &
25264                          - dQUADdR * erhead(k)&
25265                          - tuna(k)
25266 !c! this acts on Calpha
25267          gheadtail(k,4,1) = gheadtail(k,4,1)   &
25268                           + dGCLdR * erhead(k) &
25269                           + dGGBdR * erhead(k) &
25270                           + dGCVdR * erhead(k) &
25271                           + dPOLdR1 * erhead_tail(k,1) &
25272                           + dPOLdR2 * erhead_tail(k,2) &
25273                           + dGLJdR * erhead(k) &
25274                           + dQUADdR * erhead(k)&
25275                           + tuna(k)
25276         END DO
25277         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
25278         eheadtail = eheadtail &
25279                   + wstate(istate, itypi, itypj) &
25280                   * dexp(-betaT * ener(istate))
25281 !c! foreach cartesian dimension
25282         DO k = 1, 3
25283 !c! foreach of two gvdwx and gvdwc
25284          DO l = 1, 4
25285           gheadtail(k,l,2) = gheadtail(k,l,2)  &
25286                            + wstate( istate, itypi, itypj ) &
25287                            * dexp(-betaT * ener(istate)) &
25288                            * gheadtail(k,l,1)
25289           gheadtail(k,l,1) = 0.0d0
25290          END DO
25291         END DO
25292        END DO
25293 !c! Here ended the gigantic DO istate = 1, 4, which starts
25294 !c! at the beggining of the subroutine
25295
25296        DO k = 1, 3
25297         DO l = 1, 4
25298          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
25299         END DO
25300         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
25301         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
25302         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
25303         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
25304         DO l = 1, 4
25305          gheadtail(k,l,1) = 0.0d0
25306          gheadtail(k,l,2) = 0.0d0
25307         END DO
25308        END DO
25309        eheadtail = (-dlog(eheadtail)) / betaT
25310        dPOLdOM1 = 0.0d0
25311        dPOLdOM2 = 0.0d0
25312        dQUADdOM1 = 0.0d0
25313        dQUADdOM2 = 0.0d0
25314        dQUADdOM12 = 0.0d0
25315        RETURN
25316       END SUBROUTINE energy_quad
25317 !!-----------------------------------------------------------
25318       SUBROUTINE eqn(Epol)
25319       use comm_momo
25320       use calc_data
25321
25322       double precision  facd4, federmaus,epol
25323       alphapol1 = alphapol(itypi,itypj)
25324 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25325        R1 = 0.0d0
25326        DO k = 1, 3
25327 !c! Calculate head-to-tail distances
25328         R1=R1+(ctail(k,2)-chead(k,1))**2
25329        END DO
25330 !c! Pitagoras
25331        R1 = dsqrt(R1)
25332
25333 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25334 !c!     &        +dhead(1,1,itypi,itypj))**2))
25335 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25336 !c!     &        +dhead(2,1,itypi,itypj))**2))
25337 !c--------------------------------------------------------------------
25338 !c Polarization energy
25339 !c Epol
25340        MomoFac1 = (1.0d0 - chi1 * sqom2)
25341        RR1  = R1 * R1 / MomoFac1
25342        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25343        fgb1 = sqrt( RR1 + a12sq * ee1)
25344        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
25345        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
25346                / (fgb1 ** 5.0d0)
25347        dFGBdR1 = ( (R1 / MomoFac1) &
25348               * ( 2.0d0 - (0.5d0 * ee1) ) ) &
25349               / ( 2.0d0 * fgb1 )
25350        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25351                 * (2.0d0 - 0.5d0 * ee1) ) &
25352                 / (2.0d0 * fgb1)
25353        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25354 !c!       dPOLdR1 = 0.0d0
25355        dPOLdOM1 = 0.0d0
25356        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25357        DO k = 1, 3
25358         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25359        END DO
25360        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25361        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25362        facd1 = d1 * vbld_inv(i+nres)
25363        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25364
25365        DO k = 1, 3
25366         hawk = (erhead_tail(k,1) + &
25367         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
25368
25369         gvdwx(k,i) = gvdwx(k,i) &
25370                    - dPOLdR1 * hawk
25371         gvdwx(k,j) = gvdwx(k,j) &
25372                    + dPOLdR1 * (erhead_tail(k,1) &
25373        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
25374
25375         gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
25376         gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
25377
25378        END DO
25379        RETURN
25380       END SUBROUTINE eqn
25381       SUBROUTINE enq(Epol)
25382       use calc_data
25383       use comm_momo
25384        double precision facd3, adler,epol
25385        alphapol2 = alphapol(itypj,itypi)
25386 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25387        R2 = 0.0d0
25388        DO k = 1, 3
25389 !c! Calculate head-to-tail distances
25390         R2=R2+(chead(k,2)-ctail(k,1))**2
25391        END DO
25392 !c! Pitagoras
25393        R2 = dsqrt(R2)
25394
25395 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25396 !c!     &        +dhead(1,1,itypi,itypj))**2))
25397 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25398 !c!     &        +dhead(2,1,itypi,itypj))**2))
25399 !c------------------------------------------------------------------------
25400 !c Polarization energy
25401        MomoFac2 = (1.0d0 - chi2 * sqom1)
25402        RR2  = R2 * R2 / MomoFac2
25403        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
25404        fgb2 = sqrt(RR2  + a12sq * ee2)
25405        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
25406        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
25407                 / (fgb2 ** 5.0d0)
25408        dFGBdR2 = ( (R2 / MomoFac2)  &
25409               * ( 2.0d0 - (0.5d0 * ee2) ) ) &
25410               / (2.0d0 * fgb2)
25411        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
25412                 * (2.0d0 - 0.5d0 * ee2) ) &
25413                 / (2.0d0 * fgb2)
25414        dPOLdR2 = dPOLdFGB2 * dFGBdR2
25415 !c!       dPOLdR2 = 0.0d0
25416        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25417 !c!       dPOLdOM1 = 0.0d0
25418        dPOLdOM2 = 0.0d0
25419 !c!-------------------------------------------------------------------
25420 !c! Return the results
25421 !c! (See comments in Eqq)
25422        DO k = 1, 3
25423         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25424        END DO
25425        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25426        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25427        facd2 = d2 * vbld_inv(j+nres)
25428        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25429        DO k = 1, 3
25430         condor = (erhead_tail(k,2) &
25431        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
25432
25433         gvdwx(k,i) = gvdwx(k,i) &
25434                    - dPOLdR2 * (erhead_tail(k,2) &
25435        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
25436         gvdwx(k,j) = gvdwx(k,j)   &
25437                    + dPOLdR2 * condor
25438
25439         gvdwc(k,i) = gvdwc(k,i) &
25440                    - dPOLdR2 * erhead_tail(k,2)
25441         gvdwc(k,j) = gvdwc(k,j) &
25442                    + dPOLdR2 * erhead_tail(k,2)
25443
25444        END DO
25445       RETURN
25446       END SUBROUTINE enq
25447       SUBROUTINE eqd(Ecl,Elj,Epol)
25448       use calc_data
25449       use comm_momo
25450        double precision  facd4, federmaus,ecl,elj,epol
25451        alphapol1 = alphapol(itypi,itypj)
25452        w1        = wqdip(1,itypi,itypj)
25453        w2        = wqdip(2,itypi,itypj)
25454        pis       = sig0head(itypi,itypj)
25455        eps_head   = epshead(itypi,itypj)
25456 !c!-------------------------------------------------------------------
25457 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25458        R1 = 0.0d0
25459        DO k = 1, 3
25460 !c! Calculate head-to-tail distances
25461         R1=R1+(ctail(k,2)-chead(k,1))**2
25462        END DO
25463 !c! Pitagoras
25464        R1 = dsqrt(R1)
25465
25466 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25467 !c!     &        +dhead(1,1,itypi,itypj))**2))
25468 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25469 !c!     &        +dhead(2,1,itypi,itypj))**2))
25470
25471 !c!-------------------------------------------------------------------
25472 !c! ecl
25473        sparrow  = w1 * Qi * om1
25474        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
25475        Ecl = sparrow / Rhead**2.0d0 &
25476            - hawk    / Rhead**4.0d0
25477        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
25478                  + 4.0d0 * hawk    / Rhead**5.0d0
25479 !c! dF/dom1
25480        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
25481 !c! dF/dom2
25482        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
25483 !c--------------------------------------------------------------------
25484 !c Polarization energy
25485 !c Epol
25486        MomoFac1 = (1.0d0 - chi1 * sqom2)
25487        RR1  = R1 * R1 / MomoFac1
25488        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25489        fgb1 = sqrt( RR1 + a12sq * ee1)
25490        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
25491 !c!       epol = 0.0d0
25492 !c!------------------------------------------------------------------
25493 !c! derivative of Epol is Gpol...
25494        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
25495                / (fgb1 ** 5.0d0)
25496        dFGBdR1 = ( (R1 / MomoFac1)  &
25497              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
25498              / ( 2.0d0 * fgb1 )
25499        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25500                * (2.0d0 - 0.5d0 * ee1) ) &
25501                / (2.0d0 * fgb1)
25502        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25503 !c!       dPOLdR1 = 0.0d0
25504        dPOLdOM1 = 0.0d0
25505        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25506 !c!       dPOLdOM2 = 0.0d0
25507 !c!-------------------------------------------------------------------
25508 !c! Elj
25509        pom = (pis / Rhead)**6.0d0
25510        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25511 !c! derivative of Elj is Glj
25512        dGLJdR = 4.0d0 * eps_head &
25513           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
25514           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25515        DO k = 1, 3
25516         erhead(k) = Rhead_distance(k)/Rhead
25517         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25518        END DO
25519
25520        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25521        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25522        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25523        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25524        facd1 = d1 * vbld_inv(i+nres)
25525        facd2 = d2 * vbld_inv(j+nres)
25526        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25527
25528        DO k = 1, 3
25529         hawk = (erhead_tail(k,1) +  &
25530         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
25531
25532         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25533         gvdwx(k,i) = gvdwx(k,i)  &
25534                    - dGCLdR * pom&
25535                    - dPOLdR1 * hawk &
25536                    - dGLJdR * pom
25537
25538         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25539         gvdwx(k,j) = gvdwx(k,j)    &
25540                    + dGCLdR * pom  &
25541                    + dPOLdR1 * (erhead_tail(k,1) &
25542        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
25543                    + dGLJdR * pom
25544
25545
25546         gvdwc(k,i) = gvdwc(k,i)          &
25547                    - dGCLdR * erhead(k)  &
25548                    - dPOLdR1 * erhead_tail(k,1) &
25549                    - dGLJdR * erhead(k)
25550
25551         gvdwc(k,j) = gvdwc(k,j)          &
25552                    + dGCLdR * erhead(k)  &
25553                    + dPOLdR1 * erhead_tail(k,1) &
25554                    + dGLJdR * erhead(k)
25555
25556        END DO
25557        RETURN
25558       END SUBROUTINE eqd
25559       SUBROUTINE edq(Ecl,Elj,Epol)
25560 !       IMPLICIT NONE
25561        use comm_momo
25562       use calc_data
25563
25564       double precision  facd3, adler,ecl,elj,epol
25565        alphapol2 = alphapol(itypj,itypi)
25566        w1        = wqdip(1,itypi,itypj)
25567        w2        = wqdip(2,itypi,itypj)
25568        pis       = sig0head(itypi,itypj)
25569        eps_head  = epshead(itypi,itypj)
25570 !c!-------------------------------------------------------------------
25571 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25572        R2 = 0.0d0
25573        DO k = 1, 3
25574 !c! Calculate head-to-tail distances
25575         R2=R2+(chead(k,2)-ctail(k,1))**2
25576        END DO
25577 !c! Pitagoras
25578        R2 = dsqrt(R2)
25579
25580 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25581 !c!     &        +dhead(1,1,itypi,itypj))**2))
25582 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25583 !c!     &        +dhead(2,1,itypi,itypj))**2))
25584
25585
25586 !c!-------------------------------------------------------------------
25587 !c! ecl
25588        sparrow  = w1 * Qi * om1
25589        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
25590        ECL = sparrow / Rhead**2.0d0 &
25591            - hawk    / Rhead**4.0d0
25592 !c!-------------------------------------------------------------------
25593 !c! derivative of ecl is Gcl
25594 !c! dF/dr part
25595        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
25596                  + 4.0d0 * hawk    / Rhead**5.0d0
25597 !c! dF/dom1
25598        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
25599 !c! dF/dom2
25600        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
25601 !c--------------------------------------------------------------------
25602 !c Polarization energy
25603 !c Epol
25604        MomoFac2 = (1.0d0 - chi2 * sqom1)
25605        RR2  = R2 * R2 / MomoFac2
25606        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
25607        fgb2 = sqrt(RR2  + a12sq * ee2)
25608        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
25609        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
25610                / (fgb2 ** 5.0d0)
25611        dFGBdR2 = ( (R2 / MomoFac2)  &
25612                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
25613                / (2.0d0 * fgb2)
25614        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
25615                 * (2.0d0 - 0.5d0 * ee2) ) &
25616                 / (2.0d0 * fgb2)
25617        dPOLdR2 = dPOLdFGB2 * dFGBdR2
25618 !c!       dPOLdR2 = 0.0d0
25619        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25620 !c!       dPOLdOM1 = 0.0d0
25621        dPOLdOM2 = 0.0d0
25622 !c!-------------------------------------------------------------------
25623 !c! Elj
25624        pom = (pis / Rhead)**6.0d0
25625        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25626 !c! derivative of Elj is Glj
25627        dGLJdR = 4.0d0 * eps_head &
25628            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
25629            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25630 !c!-------------------------------------------------------------------
25631 !c! Return the results
25632 !c! (see comments in Eqq)
25633        DO k = 1, 3
25634         erhead(k) = Rhead_distance(k)/Rhead
25635         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25636        END DO
25637        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25638        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25639        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25640        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25641        facd1 = d1 * vbld_inv(i+nres)
25642        facd2 = d2 * vbld_inv(j+nres)
25643        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25644        DO k = 1, 3
25645         condor = (erhead_tail(k,2) &
25646        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
25647
25648         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25649         gvdwx(k,i) = gvdwx(k,i) &
25650                   - dGCLdR * pom &
25651                   - dPOLdR2 * (erhead_tail(k,2) &
25652        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
25653                   - dGLJdR * pom
25654
25655         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25656         gvdwx(k,j) = gvdwx(k,j) &
25657                   + dGCLdR * pom &
25658                   + dPOLdR2 * condor &
25659                   + dGLJdR * pom
25660
25661
25662         gvdwc(k,i) = gvdwc(k,i) &
25663                   - dGCLdR * erhead(k) &
25664                   - dPOLdR2 * erhead_tail(k,2) &
25665                   - dGLJdR * erhead(k)
25666
25667         gvdwc(k,j) = gvdwc(k,j) &
25668                   + dGCLdR * erhead(k) &
25669                   + dPOLdR2 * erhead_tail(k,2) &
25670                   + dGLJdR * erhead(k)
25671
25672        END DO
25673        RETURN
25674       END SUBROUTINE edq
25675       SUBROUTINE edd(ECL)
25676 !       IMPLICIT NONE
25677        use comm_momo
25678       use calc_data
25679
25680        double precision ecl
25681 !c!       csig = sigiso(itypi,itypj)
25682        w1 = wqdip(1,itypi,itypj)
25683        w2 = wqdip(2,itypi,itypj)
25684 !c!-------------------------------------------------------------------
25685 !c! ECL
25686        fac = (om12 - 3.0d0 * om1 * om2)
25687        c1 = (w1 / (Rhead**3.0d0)) * fac
25688        c2 = (w2 / Rhead ** 6.0d0) &
25689           * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
25690        ECL = c1 - c2
25691 !c!       write (*,*) "w1 = ", w1
25692 !c!       write (*,*) "w2 = ", w2
25693 !c!       write (*,*) "om1 = ", om1
25694 !c!       write (*,*) "om2 = ", om2
25695 !c!       write (*,*) "om12 = ", om12
25696 !c!       write (*,*) "fac = ", fac
25697 !c!       write (*,*) "c1 = ", c1
25698 !c!       write (*,*) "c2 = ", c2
25699 !c!       write (*,*) "Ecl = ", Ecl
25700 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
25701 !c!       write (*,*) "c2_2 = ",
25702 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
25703 !c!-------------------------------------------------------------------
25704 !c! dervative of ECL is GCL...
25705 !c! dECL/dr
25706        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
25707        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
25708           * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
25709        dGCLdR = c1 - c2
25710 !c! dECL/dom1
25711        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
25712        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25713           * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
25714        dGCLdOM1 = c1 - c2
25715 !c! dECL/dom2
25716        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
25717        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25718           * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
25719        dGCLdOM2 = c1 - c2
25720 !c! dECL/dom12
25721        c1 = w1 / (Rhead ** 3.0d0)
25722        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
25723        dGCLdOM12 = c1 - c2
25724 !c!-------------------------------------------------------------------
25725 !c! Return the results
25726 !c! (see comments in Eqq)
25727        DO k= 1, 3
25728         erhead(k) = Rhead_distance(k)/Rhead
25729        END DO
25730        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25731        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25732        facd1 = d1 * vbld_inv(i+nres)
25733        facd2 = d2 * vbld_inv(j+nres)
25734        DO k = 1, 3
25735
25736         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25737         gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
25738         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25739         gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
25740
25741         gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
25742         gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
25743        END DO
25744        RETURN
25745       END SUBROUTINE edd
25746       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
25747 !       IMPLICIT NONE
25748        use comm_momo
25749       use calc_data
25750
25751        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
25752        eps_out=80.0d0
25753        itypi = itype(i,1)
25754        itypj = itype(j,1)
25755 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
25756 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
25757 !c!       t_bath = 300
25758 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
25759        Rb=0.001986d0
25760        BetaT = 1.0d0 / (298.0d0 * Rb)
25761 !c! Gay-berne var's
25762        sig0ij = sigma( itypi,itypj )
25763        chi1   = chi( itypi, itypj )
25764        chi2   = chi( itypj, itypi )
25765        chi12  = chi1 * chi2
25766        chip1  = chipp( itypi, itypj )
25767        chip2  = chipp( itypj, itypi )
25768        chip12 = chip1 * chip2
25769 !       chi1=0.0
25770 !       chi2=0.0
25771 !       chi12=0.0
25772 !       chip1=0.0
25773 !       chip2=0.0
25774 !       chip12=0.0
25775 !c! not used by momo potential, but needed by sc_angular which is shared
25776 !c! by all energy_potential subroutines
25777        alf1   = 0.0d0
25778        alf2   = 0.0d0
25779        alf12  = 0.0d0
25780 !c! location, location, location
25781 !       xj  = c( 1, nres+j ) - xi
25782 !       yj  = c( 2, nres+j ) - yi
25783 !       zj  = c( 3, nres+j ) - zi
25784        dxj = dc_norm( 1, nres+j )
25785        dyj = dc_norm( 2, nres+j )
25786        dzj = dc_norm( 3, nres+j )
25787 !c! distance from center of chain(?) to polar/charged head
25788 !c!       write (*,*) "istate = ", 1
25789 !c!       write (*,*) "ii = ", 1
25790 !c!       write (*,*) "jj = ", 1
25791        d1 = dhead(1, 1, itypi, itypj)
25792        d2 = dhead(2, 1, itypi, itypj)
25793 !c! ai*aj from Fgb
25794        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
25795 !c!       a12sq = a12sq * a12sq
25796 !c! charge of amino acid itypi is...
25797        Qi  = icharge(itypi)
25798        Qj  = icharge(itypj)
25799        Qij = Qi * Qj
25800 !c! chis1,2,12
25801        chis1 = chis(itypi,itypj)
25802        chis2 = chis(itypj,itypi)
25803        chis12 = chis1 * chis2
25804        sig1 = sigmap1(itypi,itypj)
25805        sig2 = sigmap2(itypi,itypj)
25806 !c!       write (*,*) "sig1 = ", sig1
25807 !c!       write (*,*) "sig2 = ", sig2
25808 !c! alpha factors from Fcav/Gcav
25809        b1cav = alphasur(1,itypi,itypj)
25810 !       b1cav=0.0
25811        b2cav = alphasur(2,itypi,itypj)
25812        b3cav = alphasur(3,itypi,itypj)
25813        b4cav = alphasur(4,itypi,itypj)
25814        wqd = wquad(itypi, itypj)
25815 !c! used by Fgb
25816        eps_in = epsintab(itypi,itypj)
25817        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25818 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
25819 !c!-------------------------------------------------------------------
25820 !c! tail location and distance calculations
25821        Rtail = 0.0d0
25822        DO k = 1, 3
25823         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
25824         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
25825        END DO
25826 !c! tail distances will be themselves usefull elswhere
25827 !c1 (in Gcav, for example)
25828        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
25829        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
25830        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
25831        Rtail = dsqrt(  &
25832           (Rtail_distance(1)*Rtail_distance(1))  &
25833         + (Rtail_distance(2)*Rtail_distance(2))  &
25834         + (Rtail_distance(3)*Rtail_distance(3)))
25835 !c!-------------------------------------------------------------------
25836 !c! Calculate location and distance between polar heads
25837 !c! distance between heads
25838 !c! for each one of our three dimensional space...
25839        d1 = dhead(1, 1, itypi, itypj)
25840        d2 = dhead(2, 1, itypi, itypj)
25841
25842        DO k = 1,3
25843 !c! location of polar head is computed by taking hydrophobic centre
25844 !c! and moving by a d1 * dc_norm vector
25845 !c! see unres publications for very informative images
25846         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25847         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25848 !c! distance
25849 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25850 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25851         Rhead_distance(k) = chead(k,2) - chead(k,1)
25852        END DO
25853 !c! pitagoras (root of sum of squares)
25854        Rhead = dsqrt(   &
25855           (Rhead_distance(1)*Rhead_distance(1)) &
25856         + (Rhead_distance(2)*Rhead_distance(2)) &
25857         + (Rhead_distance(3)*Rhead_distance(3)))
25858 !c!-------------------------------------------------------------------
25859 !c! zero everything that should be zero'ed
25860        Egb = 0.0d0
25861        ECL = 0.0d0
25862        Elj = 0.0d0
25863        Equad = 0.0d0
25864        Epol = 0.0d0
25865        eheadtail = 0.0d0
25866        dGCLdOM1 = 0.0d0
25867        dGCLdOM2 = 0.0d0
25868        dGCLdOM12 = 0.0d0
25869        dPOLdOM1 = 0.0d0
25870        dPOLdOM2 = 0.0d0
25871        RETURN
25872       END SUBROUTINE elgrad_init
25873       end module energy