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(maxres),
 257 !     & grad_shield_locbuf(3,maxcontsshi,-1:maxres),
 258 !     & grad_shield_sidebuf(3,maxcontsshi,-1:maxres),
 259 !     & grad_shieldbuf(3,-1:maxres)
 260 !       integer ishield_listbuf(maxres),
 261 !     &shield_listbuf(maxcontsshi,maxres)
 262
 263 !      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
 264 !     & " nfgtasks",nfgtasks
 265       if (nfgtasks.gt.1) then
 266         time00=MPI_Wtime()
 267 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
 268         if (fg_rank.eq.0) then
 269           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
 270 !          print *,"Processor",myrank," BROADCAST iorder"
 271 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
 272 ! FG slaves as WEIGHTS array.
 273           weights_(1)=wsc
 274           weights_(2)=wscp
 275           weights_(3)=welec
 276           weights_(4)=wcorr
 277           weights_(5)=wcorr5
 278           weights_(6)=wcorr6
 279           weights_(7)=wel_loc
 280           weights_(8)=wturn3
 281           weights_(9)=wturn4
 282           weights_(10)=wturn6
 283           weights_(11)=wang
 284           weights_(12)=wscloc
 285           weights_(13)=wtor
 286           weights_(14)=wtor_d
 287           weights_(15)=wstrain
 288           weights_(16)=wvdwpp
 289           weights_(17)=wbond
 290           weights_(18)=scal14
 291           weights_(21)=wsccor
 292           weights_(26)=wvdwpp_nucl
 293           weights_(27)=welpp
 294           weights_(28)=wvdwpsb
 295           weights_(29)=welpsb
 296           weights_(30)=wvdwsb
 297           weights_(31)=welsb
 298           weights_(32)=wbond_nucl
 299           weights_(33)=wang_nucl
 300           weights_(34)=wsbloc
 301           weights_(35)=wtor_nucl
 302           weights_(36)=wtor_d_nucl
 303           weights_(37)=wcorr_nucl
 304           weights_(38)=wcorr3_nucl
 305           weights_(41)=wcatcat
 306           weights_(42)=wcatprot
 307           weights_(46)=wscbase
 308           weights_(47)=wscpho
 309           weights_(48)=wpeppho
 310 !          wcatcat= weights(41)
 311 !          wcatprot=weights(42)
 312
 313 ! FG Master broadcasts the WEIGHTS_ array
 314           call MPI_Bcast(weights_(1),n_ene,&
 315              MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 316         else
 317 ! FG slaves receive the WEIGHTS array
 318           call MPI_Bcast(weights(1),n_ene,&
 319               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
 320           wsc=weights(1)
 321           wscp=weights(2)
 322           welec=weights(3)
 323           wcorr=weights(4)
 324           wcorr5=weights(5)
 325           wcorr6=weights(6)
 326           wel_loc=weights(7)
 327           wturn3=weights(8)
 328           wturn4=weights(9)
 329           wturn6=weights(10)
 330           wang=weights(11)
 331           wscloc=weights(12)
 332           wtor=weights(13)
 333           wtor_d=weights(14)
 334           wstrain=weights(15)
 335           wvdwpp=weights(16)
 336           wbond=weights(17)
 337           scal14=weights(18)
 338           wsccor=weights(21)
 339           wvdwpp_nucl =weights(26)
 340           welpp  =weights(27)
 341           wvdwpsb=weights(28)
 342           welpsb =weights(29)
 343           wvdwsb =weights(30)
 344           welsb  =weights(31)
 345           wbond_nucl  =weights(32)
 346           wang_nucl   =weights(33)
 347           wsbloc =weights(34)
 348           wtor_nucl   =weights(35)
 349           wtor_d_nucl =weights(36)
 350           wcorr_nucl  =weights(37)
 351           wcorr3_nucl =weights(38)
 352           wcatcat= weights(41)
 353           wcatprot=weights(42)
 354           wscbase=weights(46)
 355           wscpho=weights(47)
 356           wpeppho=weights(48)
 357         endif
 358         time_Bcast=time_Bcast+MPI_Wtime()-time00
 359         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
 360 !        call chainbuild_cart
 361       endif
 362 !      print *,'Processor',myrank,' calling etotal ipot=',ipot
 363 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
 364 #else
 365 !      if (modecalc.eq.12.or.modecalc.eq.14) then
 366 !        call int_from_cart1(.false.)
 367 !      endif
 368 #endif
 369 #ifdef TIMING
 370       time00=MPI_Wtime()
 371 #endif
 372 !
 373 ! Compute the side-chain and electrostatic interaction energy
 374 !        print *, "Before EVDW"
 375 !      goto (101,102,103,104,105,106) ipot
 376       select case(ipot)
 377 ! Lennard-Jones potential.
 378 !  101 call elj(evdw)
 379        case (1)
 380          call elj(evdw)
 381 !d    print '(a)','Exit ELJcall el'
 382 !      goto 107
 383 ! Lennard-Jones-Kihara potential (shifted).
 384 !  102 call eljk(evdw)
 385        case (2)
 386          call eljk(evdw)
 387 !      goto 107
 388 ! Berne-Pechukas potential (dilated LJ, angular dependence).
 389 !  103 call ebp(evdw)
 390        case (3)
 391          call ebp(evdw)
 392 !      goto 107
 393 ! Gay-Berne potential (shifted LJ, angular dependence).
 394 !  104 call egb(evdw)
 395        case (4)
 396 !       print *,"MOMO",scelemode
 397         if (scelemode.eq.0) then
 398          call egb(evdw)
 399         else
 400          call emomo(evdw)
 401         endif
 402 !      goto 107
 403 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 404 !  105 call egbv(evdw)
 405        case (5)
 406          call egbv(evdw)
 407 !      goto 107
 408 ! Soft-sphere potential
 409 !  106 call e_softsphere(evdw)
 410        case (6)
 411          call e_softsphere(evdw)
 412 !
 413 ! Calculate electrostatic (H-bonding) energy of the main chain.
 414 !
 415 !  107 continue
 416        case default
 417          write(iout,*)"Wrong ipot"
 418 !         return
 419 !   50 continue
 420       end select
 421 !      continue
 422 !        print *,"after EGB"
 423 ! shielding effect
 424        if (shield_mode.eq.2) then
 425                  call set_shield_fac2
 426        endif
 427 !       print *,"AFTER EGB",ipot,evdw
 428 !mc
 429 !mc Sep-06: egb takes care of dynamic ss bonds too
 430 !mc
 431 !      if (dyn_ss) call dyn_set_nss
 432 !      print *,"Processor",myrank," computed USCSC"
 433 #ifdef TIMING
 434       time01=MPI_Wtime()
 435 #endif
 436       call vec_and_deriv
 437 #ifdef TIMING
 438       time_vec=time_vec+MPI_Wtime()-time01
 439 #endif
 440 !        print *,"Processor",myrank," left VEC_AND_DERIV"
 441       if (ipot.lt.6) then
 442 #ifdef SPLITELE
 443 !         print *,"after ipot if", ipot
 444          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
 445              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 446              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 447              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 448 #else
 449          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
 450              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
 451              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
 452              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 453 #endif
 454 !            print *,"just befor eelec call"
 455             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 456 !         write (iout,*) "ELEC calc"
 457          else
 458             ees=0.0d0
 459             evdw1=0.0d0
 460             eel_loc=0.0d0
 461             eello_turn3=0.0d0
 462             eello_turn4=0.0d0
 463          endif
 464       else
 465 !        write (iout,*) "Soft-spheer ELEC potential"
 466         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
 467          eello_turn4)
 468       endif
 469 !      print *,"Processor",myrank," computed UELEC"
 470 !
 471 ! Calculate excluded-volume interaction energy between peptide groups
 472 ! and side chains.
 473 !
 474 !elwrite(iout,*) "in etotal calc exc;luded",ipot
 475
 476       if (ipot.lt.6) then
 477        if(wscp.gt.0d0) then
 478         call escp(evdw2,evdw2_14)
 479        else
 480         evdw2=0
 481         evdw2_14=0
 482        endif
 483       else
 484 !        write (iout,*) "Soft-sphere SCP potential"
 485         call escp_soft_sphere(evdw2,evdw2_14)
 486       endif
 487 !       write(iout,*) "in etotal before ebond",ipot
 488
 489 !
 490 ! Calculate the bond-stretching energy
 491 !
 492       call ebond(estr)
 493 !       print *,"EBOND",estr
 494 !       write(iout,*) "in etotal afer ebond",ipot
 495
 496 !
 497 ! Calculate the disulfide-bridge and other energy and the contributions
 498 ! from other distance constraints.
 499 !      print *,'Calling EHPB'
 500       call edis(ehpb)
 501 !elwrite(iout,*) "in etotal afer edis",ipot
 502 !      print *,'EHPB exitted succesfully.'
 503 !
 504 ! Calculate the virtual-bond-angle energy.
 505 !
 506       if (wang.gt.0d0) then
 507         call ebend(ebe,ethetacnstr)
 508       else
 509         ebe=0
 510         ethetacnstr=0
 511       endif
 512 !      print *,"Processor",myrank," computed UB"
 513 !
 514 ! Calculate the SC local energy.
 515 !
 516       call esc(escloc)
 517 !elwrite(iout,*) "in etotal afer esc",ipot
 518 !      print *,"Processor",myrank," computed USC"
 519 !
 520 ! Calculate the virtual-bond torsional energy.
 521 !
 522 !d    print *,'nterm=',nterm
 523       if (wtor.gt.0) then
 524        call etor(etors,edihcnstr)
 525       else
 526        etors=0
 527        edihcnstr=0
 528       endif
 529 !      print *,"Processor",myrank," computed Utor"
 530 !
 531 ! 6/23/01 Calculate double-torsional energy
 532 !
 533 !elwrite(iout,*) "in etotal",ipot
 534       if (wtor_d.gt.0) then
 535        call etor_d(etors_d)
 536       else
 537        etors_d=0
 538       endif
 539 !      print *,"Processor",myrank," computed Utord"
 540 !
 541 ! 21/5/07 Calculate local sicdechain correlation energy
 542 !
 543       if (wsccor.gt.0.0d0) then
 544         call eback_sc_corr(esccor)
 545       else
 546         esccor=0.0d0
 547       endif
 548 !      print *,"Processor",myrank," computed Usccorr"
 549 !
 550 ! 12/1/95 Multi-body terms
 551 !
 552       n_corr=0
 553       n_corr1=0
 554       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
 555           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 556          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 557 !d         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 558 !d     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 559       else
 560          ecorr=0.0d0
 561          ecorr5=0.0d0
 562          ecorr6=0.0d0
 563          eturn6=0.0d0
 564       endif
 565 !elwrite(iout,*) "in etotal",ipot
 566       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 567          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 568 !d         write (iout,*) "multibody_hb ecorr",ecorr
 569       endif
 570 !elwrite(iout,*) "afeter  multibody hb"
 571
 572 !      print *,"Processor",myrank," computed Ucorr"
 573 !
 574 ! If performing constraint dynamics, call the constraint energy
 575 !  after the equilibration time
 576       if(usampl.and.totT.gt.eq_time) then
 577 !elwrite(iout,*) "afeter  multibody hb"
 578          call EconstrQ
 579 !elwrite(iout,*) "afeter  multibody hb"
 580          call Econstr_back
 581 !elwrite(iout,*) "afeter  multibody hb"
 582       else
 583          Uconst=0.0d0
 584          Uconst_back=0.0d0
 585       endif
 586       call flush(iout)
 587 !         write(iout,*) "after Econstr"
 588
 589       if (wliptran.gt.0) then
 590 !        print *,"PRZED WYWOLANIEM"
 591         call Eliptransfer(eliptran)
 592       else
 593        eliptran=0.0d0
 594       endif
 595       if (fg_rank.eq.0) then
 596       if (AFMlog.gt.0) then
 597         call AFMforce(Eafmforce)
 598       else if (selfguide.gt.0) then
 599         call AFMvel(Eafmforce)
 600       endif
 601       endif
 602       if (tubemode.eq.1) then
 603        call calctube(etube)
 604       else if (tubemode.eq.2) then
 605        call calctube2(etube)
 606       elseif (tubemode.eq.3) then
 607        call calcnano(etube)
 608       else
 609        etube=0.0d0
 610       endif
 611 !--------------------------------------------------------
 612 !      write (iout,*) "NRES_MOLEC(2),",nres_molec(2)
 613 !      print *,"before",ees,evdw1,ecorr
 614       if (nres_molec(2).gt.0) then
 615       call ebond_nucl(estr_nucl)
 616       call ebend_nucl(ebe_nucl)
 617       call etor_nucl(etors_nucl)
 618       call esb_gb(evdwsb,eelsb)
 619       call epp_nucl_sub(evdwpp,eespp)
 620       call epsb(evdwpsb,eelpsb)
 621       call esb(esbloc)
 622       call multibody_hb_nucl(ecorr_nucl,ecorr3_nucl,n_corr,n_corr1)
 623       else
 624        etors_nucl=0.0d0
 625        estr_nucl=0.0d0
 626        ebe_nucl=0.0d0
 627        evdwsb=0.0d0
 628        eelsb=0.0d0
 629        esbloc=0.0d0
 630       endif
 631       if (nfgtasks.gt.1) then
 632       if (fg_rank.eq.0) then
 633       call ecatcat(ecationcation)
 634       endif
 635       else
 636       call ecatcat(ecationcation)
 637       endif
 638       call ecat_prot(ecation_prot)
 639       if (nres_molec(2).gt.0) then
 640       call eprot_sc_base(escbase)
 641       call epep_sc_base(epepbase)
 642       call eprot_sc_phosphate(escpho)
 643       call eprot_pep_phosphate(epeppho)
 644       else
 645       epepbase=0.0
 646       escbase=0.0
 647       escpho=0.0
 648       epeppho=0.0
 649       endif
 650 !      call ecatcat(ecationcation)
 651 !      print *,"after ebend", ebe_nucl
 652 #ifdef TIMING
 653       time_enecalc=time_enecalc+MPI_Wtime()-time00
 654 #endif
 655 !      print *,"Processor",myrank," computed Uconstr"
 656 #ifdef TIMING
 657       time00=MPI_Wtime()
 658 #endif
 659 !
 660 ! Sum the energies
 661 !
 662       energia(1)=evdw
 663 #ifdef SCP14
 664       energia(2)=evdw2-evdw2_14
 665       energia(18)=evdw2_14
 666 #else
 667       energia(2)=evdw2
 668       energia(18)=0.0d0
 669 #endif
 670 #ifdef SPLITELE
 671       energia(3)=ees
 672       energia(16)=evdw1
 673 #else
 674       energia(3)=ees+evdw1
 675       energia(16)=0.0d0
 676 #endif
 677       energia(4)=ecorr
 678       energia(5)=ecorr5
 679       energia(6)=ecorr6
 680       energia(7)=eel_loc
 681       energia(8)=eello_turn3
 682       energia(9)=eello_turn4
 683       energia(10)=eturn6
 684       energia(11)=ebe
 685       energia(12)=escloc
 686       energia(13)=etors
 687       energia(14)=etors_d
 688       energia(15)=ehpb
 689       energia(19)=edihcnstr
 690       energia(17)=estr
 691       energia(20)=Uconst+Uconst_back
 692       energia(21)=esccor
 693       energia(22)=eliptran
 694       energia(23)=Eafmforce
 695       energia(24)=ethetacnstr
 696       energia(25)=etube
 697 !---------------------------------------------------------------
 698       energia(26)=evdwpp
 699       energia(27)=eespp
 700       energia(28)=evdwpsb
 701       energia(29)=eelpsb
 702       energia(30)=evdwsb
 703       energia(31)=eelsb
 704       energia(32)=estr_nucl
 705       energia(33)=ebe_nucl
 706       energia(34)=esbloc
 707       energia(35)=etors_nucl
 708       energia(36)=etors_d_nucl
 709       energia(37)=ecorr_nucl
 710       energia(38)=ecorr3_nucl
 711 !----------------------------------------------------------------------
 712 !    Here are the energies showed per procesor if the are more processors
 713 !    per molecule then we sum it up in sum_energy subroutine
 714 !      print *," Processor",myrank," calls SUM_ENERGY"
 715       energia(41)=ecation_prot
 716       energia(42)=ecationcation
 717       energia(46)=escbase
 718       energia(47)=epepbase
 719       energia(48)=escpho
 720       energia(49)=epeppho
 721       call sum_energy(energia,.true.)
 722       if (dyn_ss) call dyn_set_nss
 723 !      print *," Processor",myrank," left SUM_ENERGY"
 724 #ifdef TIMING
 725       time_sumene=time_sumene+MPI_Wtime()-time00
 726 #endif
 727 !el        call enerprint(energia)
 728 !elwrite(iout,*)"finish etotal"
 729       return
 730       end subroutine etotal
 731 !-----------------------------------------------------------------------------
 732       subroutine sum_energy(energia,reduce)
 733 !      implicit real*8 (a-h,o-z)
 734 !      include 'DIMENSIONS'
 735 #ifndef ISNAN
 736       external proc_proc
 737 #ifdef WINPGI
 738 !MS$ATTRIBUTES C ::  proc_proc
 739 #endif
 740 #endif
 741 #ifdef MPI
 742       include "mpif.h"
 743 #endif
 744 !      include 'COMMON.SETUP'
 745 !      include 'COMMON.IOUNITS'
 746       real(kind=8) :: energia(0:n_ene),enebuff(0:n_ene+1)
 747 !      include 'COMMON.FFIELD'
 748 !      include 'COMMON.DERIV'
 749 !      include 'COMMON.INTERACT'
 750 !      include 'COMMON.SBRIDGE'
 751 !      include 'COMMON.CHAIN'
 752 !      include 'COMMON.VAR'
 753 !      include 'COMMON.CONTROL'
 754 !      include 'COMMON.TIME1'
 755       logical :: reduce
 756       real(kind=8) :: evdw,evdw2,evdw2_14,ees,evdw1,ecorr,ecorr5,ecorr6
 757       real(kind=8) :: eel_loc,eello_turn3,eello_turn4,eturn6,ebe,escloc
 758       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,esccor,etot,   &
 759         eliptran,etube, Eafmforce,ethetacnstr
 760       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
 761                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
 762                       ecorr3_nucl
 763       real(kind=8) :: ecation_prot,ecationcation
 764       real(kind=8) :: escbase,epepbase,escpho,epeppho
 765       integer :: i
 766 #ifdef MPI
 767       integer :: ierr
 768       real(kind=8) :: time00
 769       if (nfgtasks.gt.1 .and. reduce) then
 770
 771 #ifdef DEBUG
 772         write (iout,*) "energies before REDUCE"
 773         call enerprint(energia)
 774         call flush(iout)
 775 #endif
 776         do i=0,n_ene
 777           enebuff(i)=energia(i)
 778         enddo
 779         time00=MPI_Wtime()
 780         call MPI_Barrier(FG_COMM,IERR)
 781         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 782         time00=MPI_Wtime()
 783         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,&
 784           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 785 #ifdef DEBUG
 786         write (iout,*) "energies after REDUCE"
 787         call enerprint(energia)
 788         call flush(iout)
 789 #endif
 790         time_Reduce=time_Reduce+MPI_Wtime()-time00
 791       endif
 792       if (fg_rank.eq.0) then
 793 #endif
 794       evdw=energia(1)
 795 #ifdef SCP14
 796       evdw2=energia(2)+energia(18)
 797       evdw2_14=energia(18)
 798 #else
 799       evdw2=energia(2)
 800 #endif
 801 #ifdef SPLITELE
 802       ees=energia(3)
 803       evdw1=energia(16)
 804 #else
 805       ees=energia(3)
 806       evdw1=0.0d0
 807 #endif
 808       ecorr=energia(4)
 809       ecorr5=energia(5)
 810       ecorr6=energia(6)
 811       eel_loc=energia(7)
 812       eello_turn3=energia(8)
 813       eello_turn4=energia(9)
 814       eturn6=energia(10)
 815       ebe=energia(11)
 816       escloc=energia(12)
 817       etors=energia(13)
 818       etors_d=energia(14)
 819       ehpb=energia(15)
 820       edihcnstr=energia(19)
 821       estr=energia(17)
 822       Uconst=energia(20)
 823       esccor=energia(21)
 824       eliptran=energia(22)
 825       Eafmforce=energia(23)
 826       ethetacnstr=energia(24)
 827       etube=energia(25)
 828       evdwpp=energia(26)
 829       eespp=energia(27)
 830       evdwpsb=energia(28)
 831       eelpsb=energia(29)
 832       evdwsb=energia(30)
 833       eelsb=energia(31)
 834       estr_nucl=energia(32)
 835       ebe_nucl=energia(33)
 836       esbloc=energia(34)
 837       etors_nucl=energia(35)
 838       etors_d_nucl=energia(36)
 839       ecorr_nucl=energia(37)
 840       ecorr3_nucl=energia(38)
 841       ecation_prot=energia(41)
 842       ecationcation=energia(42)
 843       escbase=energia(46)
 844       epepbase=energia(47)
 845       escpho=energia(48)
 846       epeppho=energia(49)
 847 !      energia(41)=ecation_prot
 848 !      energia(42)=ecationcation
 849
 850
 851 #ifdef SPLITELE
 852       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1 &
 853        +wang*ebe+wtor*etors+wscloc*escloc &
 854        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 855        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 856        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 857        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 858        +Eafmforce+ethetacnstr  &
 859        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 860        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 861        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 862        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
 863        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
 864        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
 865 #else
 866       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1) &
 867        +wang*ebe+wtor*etors+wscloc*escloc &
 868        +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5 &
 869        +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3 &
 870        +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d &
 871        +wbond*estr+Uconst+wsccor*esccor+wliptran*eliptran+wtube*etube&
 872        +Eafmforce+ethetacnstr &
 873        +wbond_nucl*estr_nucl+wang_nucl*ebe_nucl&
 874        +wvdwpp_nucl*evdwpp+welpp*eespp+wvdwpsb*evdwpsb+welpsb*eelpsb&
 875        +wvdwsb*evdwsb+welsb*eelsb+wsbloc*esbloc+wtor_nucl*etors_nucl&
 876        +wtor_d_nucl*etors_d_nucl+wcorr_nucl*ecorr_nucl+wcorr3_nucl*ecorr3_nucl&
 877        +wcatprot*ecation_prot+wcatcat*ecationcation+wscbase*escbase&
 878        +wpepbase*epepbase+wscpho*escpho+wpeppho*epeppho
 879 #endif
 880       energia(0)=etot
 881 ! detecting NaNQ
 882 #ifdef ISNAN
 883 #ifdef AIX
 884       if (isnan(etot).ne.0) energia(0)=1.0d+99
 885 #else
 886       if (isnan(etot)) energia(0)=1.0d+99
 887 #endif
 888 #else
 889       i=0
 890 #ifdef WINPGI
 891       idumm=proc_proc(etot,i)
 892 #else
 893       call proc_proc(etot,i)
 894 #endif
 895       if(i.eq.1)energia(0)=1.0d+99
 896 #endif
 897 #ifdef MPI
 898       endif
 899 #endif
 900 !      call enerprint(energia)
 901       call flush(iout)
 902       return
 903       end subroutine sum_energy
 904 !-----------------------------------------------------------------------------
 905       subroutine rescale_weights(t_bath)
 906 !      implicit real*8 (a-h,o-z)
 907 #ifdef MPI
 908       include 'mpif.h'
 909 #endif
 910 !      include 'DIMENSIONS'
 911 !      include 'COMMON.IOUNITS'
 912 !      include 'COMMON.FFIELD'
 913 !      include 'COMMON.SBRIDGE'
 914       real(kind=8) :: kfac=2.4d0
 915       real(kind=8) :: x,x2,x3,x4,x5,licznik=1.12692801104297249644
 916 !el local variables
 917       real(kind=8) :: t_bath,facT(6) !,facT2,facT3,facT4,facT5,facT6
 918       real(kind=8) :: T0=3.0d2
 919       integer :: ierror
 920 !      facT=temp0/t_bath
 921 !      facT=2*temp0/(t_bath+temp0)
 922       if (rescale_mode.eq.0) then
 923         facT(1)=1.0d0
 924         facT(2)=1.0d0
 925         facT(3)=1.0d0
 926         facT(4)=1.0d0
 927         facT(5)=1.0d0
 928         facT(6)=1.0d0
 929       else if (rescale_mode.eq.1) then
 930         facT(1)=kfac/(kfac-1.0d0+t_bath/temp0)
 931         facT(2)=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 932         facT(3)=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 933         facT(4)=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 934         facT(5)=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 935 #ifdef WHAM_RUN
 936 !#if defined(WHAM_RUN) || defined(CLUSTER)
 937 #if defined(FUNCTH)
 938 !          tt = 1.0d0/(beta_h(ib,ipar)*1.987D-3)
 939         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 940 #elif defined(FUNCT)
 941         facT(6)=t_bath/T0
 942 #else
 943         facT(6)=1.0d0
 944 #endif
 945 #endif
 946       else if (rescale_mode.eq.2) then
 947         x=t_bath/temp0
 948         x2=x*x
 949         x3=x2*x
 950         x4=x3*x
 951         x5=x4*x
 952         facT(1)=licznik/dlog(dexp(x)+dexp(-x))
 953         facT(2)=licznik/dlog(dexp(x2)+dexp(-x2))
 954         facT(3)=licznik/dlog(dexp(x3)+dexp(-x3))
 955         facT(4)=licznik/dlog(dexp(x4)+dexp(-x4))
 956         facT(5)=licznik/dlog(dexp(x5)+dexp(-x5))
 957 #ifdef WHAM_RUN
 958 !#if defined(WHAM_RUN) || defined(CLUSTER)
 959 #if defined(FUNCTH)
 960         facT(6)=(320.0+80.0*dtanh((t_bath-320.0)/80.0))/320.0
 961 #elif defined(FUNCT)
 962         facT(6)=t_bath/T0
 963 #else
 964         facT(6)=1.0d0
 965 #endif
 966 #endif
 967       else
 968         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 969         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 970 #ifdef MPI
 971        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 972 #endif
 973        stop 555
 974       endif
 975       welec=weights(3)*fact(1)
 976       wcorr=weights(4)*fact(3)
 977       wcorr5=weights(5)*fact(4)
 978       wcorr6=weights(6)*fact(5)
 979       wel_loc=weights(7)*fact(2)
 980       wturn3=weights(8)*fact(2)
 981       wturn4=weights(9)*fact(3)
 982       wturn6=weights(10)*fact(5)
 983       wtor=weights(13)*fact(1)
 984       wtor_d=weights(14)*fact(2)
 985       wsccor=weights(21)*fact(1)
 986
 987       return
 988       end subroutine rescale_weights
 989 !-----------------------------------------------------------------------------
 990       subroutine enerprint(energia)
 991 !      implicit real*8 (a-h,o-z)
 992 !      include 'DIMENSIONS'
 993 !      include 'COMMON.IOUNITS'
 994 !      include 'COMMON.FFIELD'
 995 !      include 'COMMON.SBRIDGE'
 996 !      include 'COMMON.MD'
 997       real(kind=8) :: energia(0:n_ene)
 998 !el local variables
 999       real(kind=8) :: etot,evdw,evdw2,ees,evdw1,ecorr,ecorr5,ecorr6,eel_loc
1000       real(kind=8) :: eello_turn6,eello_turn3,eello_turn4,ebe,escloc
1001       real(kind=8) :: etors,etors_d,ehpb,edihcnstr,estr,Uconst,esccor,eliptran,&
1002        etube,ethetacnstr,Eafmforce
1003       real(kind=8) :: evdwpp,eespp,evdwpsb,eelpsb,evdwsb,eelsb,estr_nucl,&
1004                       ebe_nucl,esbloc,etors_nucl,etors_d_nucl,ecorr_nucl,&
1005                       ecorr3_nucl
1006       real(kind=8) :: ecation_prot,ecationcation
1007       real(kind=8) :: escbase,epepbase,escpho,epeppho
1008
1009       etot=energia(0)
1010       evdw=energia(1)
1011       evdw2=energia(2)
1012 #ifdef SCP14
1013       evdw2=energia(2)+energia(18)
1014 #else
1015       evdw2=energia(2)
1016 #endif
1017       ees=energia(3)
1018 #ifdef SPLITELE
1019       evdw1=energia(16)
1020 #endif
1021       ecorr=energia(4)
1022       ecorr5=energia(5)
1023       ecorr6=energia(6)
1024       eel_loc=energia(7)
1025       eello_turn3=energia(8)
1026       eello_turn4=energia(9)
1027       eello_turn6=energia(10)
1028       ebe=energia(11)
1029       escloc=energia(12)
1030       etors=energia(13)
1031       etors_d=energia(14)
1032       ehpb=energia(15)
1033       edihcnstr=energia(19)
1034       estr=energia(17)
1035       Uconst=energia(20)
1036       esccor=energia(21)
1037       eliptran=energia(22)
1038       Eafmforce=energia(23)
1039       ethetacnstr=energia(24)
1040       etube=energia(25)
1041       evdwpp=energia(26)
1042       eespp=energia(27)
1043       evdwpsb=energia(28)
1044       eelpsb=energia(29)
1045       evdwsb=energia(30)
1046       eelsb=energia(31)
1047       estr_nucl=energia(32)
1048       ebe_nucl=energia(33)
1049       esbloc=energia(34)
1050       etors_nucl=energia(35)
1051       etors_d_nucl=energia(36)
1052       ecorr_nucl=energia(37)
1053       ecorr3_nucl=energia(38)
1054       ecation_prot=energia(41)
1055       ecationcation=energia(42)
1056       escbase=energia(46)
1057       epepbase=energia(47)
1058       escpho=energia(48)
1059       epeppho=energia(49)
1060 #ifdef SPLITELE
1061       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,&
1062         estr,wbond,ebe,wang,&
1063         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1064         ecorr,wcorr,&
1065         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1066         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,&
1067         edihcnstr,ethetacnstr,ebr*nss,&
1068         Uconst,eliptran,wliptran,Eafmforce,etube,wtube, & ! till now protein
1069         estr_nucl,wbond_nucl,ebe_nucl,wang_nucl, &
1070         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb,&
1071         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl,&
1072         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1073         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat, &
1074         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1075         etot
1076    10 format (/'Virtual-chain energies:'// &
1077        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1078        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1079        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1080        'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/ &
1081        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1082        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1083        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1084        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1085        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1086        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1087        ' (SS bridges & dist. cnstr.)'/ &
1088        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1089        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1090        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1091        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1092        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1093        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1094        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1095        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1096        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1097        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1098        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1099        'UCONST= ',1pE16.6,' (Constraint energy)'/ &
1100        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/&
1101        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1102        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1103        'ESTR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1104        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1105        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1106        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1107        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1108        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1109        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1110        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1111        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1112        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1113        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1114        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1115        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1116        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1117        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1118        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1119        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1120        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1121        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1122        'ETOT=  ',1pE16.6,' (total)')
1123 #else
1124       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,&
1125         estr,wbond,ebe,wang,&
1126         escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,&
1127         ecorr,wcorr,&
1128         ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,&
1129         eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,&
1130         ethetacnstr,ebr*nss,Uconst,eliptran,wliptran,Eafmforc,     &
1131         etube,wtube, &
1132         estr_nucl,wbond_nucl, ebe_nucl,wang_nucl,&
1133         evdwpp,wvdwpp_nucl,eespp,welpp,evdwpsb,wvdwpsb,eelpsb,welpsb&
1134         evdwsb,wvdwsb,eelsb,welsb,esbloc,wsbloc,etors_nucl,wtor_nucl&
1135         etors_d_nucl,wtor_d_nucl,ecorr_nucl,wcorr_nucl,&
1136         ecorr3_nucl,wcorr3_nucl,ecation_prot,wcatprot,ecationcation,wcatcat,  &
1137         escbase,wscbase,epepbase,wpepbase,escpho,wscpho,epeppho,wpeppho,&
1138         etot
1139    10 format (/'Virtual-chain energies:'// &
1140        'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/ &
1141        'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/ &
1142        'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/ &
1143        'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/ &
1144        'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/ &
1145        'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/ &
1146        'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/ &
1147        'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/ &
1148        'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6, &
1149        ' (SS bridges & dist. cnstr.)'/ &
1150        'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1151        'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1152        'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/ &
1153        'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/ &
1154        'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/ &
1155        'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/ &
1156        'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/ &
1157        'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/ &
1158        'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/ &
1159        'ETHETC= ',1pE16.6,' (valence angle constraints)'/ &
1160        'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/ &
1161        'UCONST=',1pE16.6,' (Constraint energy)'/ &
1162        'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/ &
1163        'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/ &
1164        'ETUBE=',1pE16.6, ' WEIGHT=',1pD16.6,' (cylindrical energy)'/ &
1165        'ESTR_nucl=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching for nucleic)'/ &
1166        'EBE_nucl=',1pE16.6,' WEIGHT=',1pD16.6,' (bending for nucleic)'/ &
1167        'EVDW_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate VDW)'/ &
1168        'EESPP_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-phosphate elec)'/ &
1169        'EVDWPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase VDW)'/ &
1170        'EESPSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(phosphate-sugarbase elec)'/ &
1171        'EVDWSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase VDW)'/ &
1172        'EESSB_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase-sugarbase elec)'/ &
1173        'ESBLOC_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(sugarbase rotamer)'/ &
1174        'ETORS_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(torsional)'/ &
1175        'ETORSD_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(double torsional)'/ &
1176        'ECORR_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 4th order)'/ &
1177        'ECORR3_nucl=',1pE16.6,' WEIGHT=',1pD16.6,'(multibody 3th order)'/ &
1178        'ECATPROT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation prot)'/ &
1179        'ECATCAT=',1pE16.6,' WEIGHT=',1pD16.6,'(cation cation)'/ &
1180        'ESCBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-base)'/ &
1181        'EPEPBASE=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-base)'/ &
1182        'ESCPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(sc-prot nucl-phosphate)'/&
1183        'EPEPPHO=',1pE16.6,' WEIGHT=',1pD16.6,'(pep-prot nucl-phosphate)'/&
1184        'ETOT=  ',1pE16.6,' (total)')
1185 #endif
1186       return
1187       end subroutine enerprint
1188 !-----------------------------------------------------------------------------
1189       subroutine elj(evdw)
1190 !
1191 ! This subroutine calculates the interaction energy of nonbonded side chains
1192 ! assuming the LJ potential of interaction.
1193 !
1194 !      implicit real*8 (a-h,o-z)
1195 !      include 'DIMENSIONS'
1196       real(kind=8),parameter :: accur=1.0d-10
1197 !      include 'COMMON.GEO'
1198 !      include 'COMMON.VAR'
1199 !      include 'COMMON.LOCAL'
1200 !      include 'COMMON.CHAIN'
1201 !      include 'COMMON.DERIV'
1202 !      include 'COMMON.INTERACT'
1203 !      include 'COMMON.TORSION'
1204 !      include 'COMMON.SBRIDGE'
1205 !      include 'COMMON.NAMES'
1206 !      include 'COMMON.IOUNITS'
1207 !      include 'COMMON.CONTACTS'
1208       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1209       integer :: num_conti
1210 !el local variables
1211       integer :: i,itypi,iint,j,itypi1,itypj,k
1212       real(kind=8) :: rij,rcut,fcont,fprimcont,rrij
1213       real(kind=8) :: evdw,xi,yi,zi,xj,yj,zj
1214       real(kind=8) :: eps0ij,fac,e1,e2,evdwij,sigij,r0ij
1215
1216 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1217       evdw=0.0D0
1218 !      allocate(num_cont(iatsc_s:iatsc_e)) !(maxres) nnt,nct-2
1219 !      allocate(jcont(nres/4,iatsc_s:iatsc_e)) !(maxconts,maxres) (maxconts=maxres/4)
1220 !      allocate(facont(nres/4,iatsc_s:iatsc_e))      !(maxconts,maxres)
1221 !      allocate(gacont(3,nres/4,iatsc_s:iatsc_e))      !(3,maxconts,maxres)
1222
1223       do i=iatsc_s,iatsc_e
1224         itypi=iabs(itype(i,1))
1225         if (itypi.eq.ntyp1) cycle
1226         itypi1=iabs(itype(i+1,1))
1227         xi=c(1,nres+i)
1228         yi=c(2,nres+i)
1229         zi=c(3,nres+i)
1230 ! Change 12/1/95
1231         num_conti=0
1232 !
1233 ! Calculate SC interaction energy.
1234 !
1235         do iint=1,nint_gr(i)
1236 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1237 !d   &                  'iend=',iend(i,iint)
1238           do j=istart(i,iint),iend(i,iint)
1239             itypj=iabs(itype(j,1))
1240             if (itypj.eq.ntyp1) cycle
1241             xj=c(1,nres+j)-xi
1242             yj=c(2,nres+j)-yi
1243             zj=c(3,nres+j)-zi
1244 ! Change 12/1/95 to calculate four-body interactions
1245             rij=xj*xj+yj*yj+zj*zj
1246             rrij=1.0D0/rij
1247 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1248             eps0ij=eps(itypi,itypj)
1249             fac=rrij**expon2
1250             e1=fac*fac*aa_aq(itypi,itypj)
1251             e2=fac*bb_aq(itypi,itypj)
1252             evdwij=e1+e2
1253 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1254 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1255 !d          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1256 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1257 !d   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1258 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1259             evdw=evdw+evdwij
1260 !
1261 ! Calculate the components of the gradient in DC and X
1262 !
1263             fac=-rrij*(e1+evdwij)
1264             gg(1)=xj*fac
1265             gg(2)=yj*fac
1266             gg(3)=zj*fac
1267             do k=1,3
1268               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1269               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1270               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1271               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1272             enddo
1273 !grad            do k=i,j-1
1274 !grad              do l=1,3
1275 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1276 !grad              enddo
1277 !grad            enddo
1278 !
1279 ! 12/1/95, revised on 5/20/97
1280 !
1281 ! Calculate the contact function. The ith column of the array JCONT will
1282 ! contain the numbers of atoms that make contacts with the atom I (of numbers
1283 ! greater than I). The arrays FACONT and GACONT will contain the values of
1284 ! the contact function and its derivative.
1285 !
1286 ! Uncomment next line, if the correlation interactions include EVDW explicitly.
1287 !           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1288 ! Uncomment next line, if the correlation interactions are contact function only
1289             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1290               rij=dsqrt(rij)
1291               sigij=sigma(itypi,itypj)
1292               r0ij=rs0(itypi,itypj)
1293 !
1294 ! Check whether the SC's are not too far to make a contact.
1295 !
1296               rcut=1.5d0*r0ij
1297               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1298 ! Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1299 !
1300               if (fcont.gt.0.0D0) then
1301 ! If the SC-SC distance if close to sigma, apply spline.
1302 !Adam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1303 !Adam &             fcont1,fprimcont1)
1304 !Adam           fcont1=1.0d0-fcont1
1305 !Adam           if (fcont1.gt.0.0d0) then
1306 !Adam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1307 !Adam             fcont=fcont*fcont1
1308 !Adam           endif
1309 ! Uncomment following 4 lines to have the geometric average of the epsilon0's
1310 !ga             eps0ij=1.0d0/dsqrt(eps0ij)
1311 !ga             do k=1,3
1312 !ga               gg(k)=gg(k)*eps0ij
1313 !ga             enddo
1314 !ga             eps0ij=-evdwij*eps0ij
1315 ! Uncomment for AL's type of SC correlation interactions.
1316 !adam           eps0ij=-evdwij
1317                 num_conti=num_conti+1
1318                 jcont(num_conti,i)=j
1319                 facont(num_conti,i)=fcont*eps0ij
1320                 fprimcont=eps0ij*fprimcont/rij
1321                 fcont=expon*fcont
1322 !Adam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1323 !Adam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1324 !Adam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1325 ! Uncomment following 3 lines for Skolnick's type of SC correlation.
1326                 gacont(1,num_conti,i)=-fprimcont*xj
1327                 gacont(2,num_conti,i)=-fprimcont*yj
1328                 gacont(3,num_conti,i)=-fprimcont*zj
1329 !d              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1330 !d              write (iout,'(2i3,3f10.5)')
1331 !d   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1332               endif
1333             endif
1334           enddo      ! j
1335         enddo        ! iint
1336 ! Change 12/1/95
1337         num_cont(i)=num_conti
1338       enddo          ! i
1339       do i=1,nct
1340         do j=1,3
1341           gvdwc(j,i)=expon*gvdwc(j,i)
1342           gvdwx(j,i)=expon*gvdwx(j,i)
1343         enddo
1344       enddo
1345 !******************************************************************************
1346 !
1347 !                              N O T E !!!
1348 !
1349 ! To save time, the factor of EXPON has been extracted from ALL components
1350 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
1351 ! use!
1352 !
1353 !******************************************************************************
1354       return
1355       end subroutine elj
1356 !-----------------------------------------------------------------------------
1357       subroutine eljk(evdw)
1358 !
1359 ! This subroutine calculates the interaction energy of nonbonded side chains
1360 ! assuming the LJK potential of interaction.
1361 !
1362 !      implicit real*8 (a-h,o-z)
1363 !      include 'DIMENSIONS'
1364 !      include 'COMMON.GEO'
1365 !      include 'COMMON.VAR'
1366 !      include 'COMMON.LOCAL'
1367 !      include 'COMMON.CHAIN'
1368 !      include 'COMMON.DERIV'
1369 !      include 'COMMON.INTERACT'
1370 !      include 'COMMON.IOUNITS'
1371 !      include 'COMMON.NAMES'
1372       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
1373       logical :: scheck
1374 !el local variables
1375       integer :: i,iint,j,itypi,itypi1,k,itypj
1376       real(kind=8) :: rrij,xi,yi,zi,xj,yj,zj,fac_augm,e_augm,r_inv_ij
1377       real(kind=8) :: evdw,rij,r_shift_inv,fac,e1,e2,evdwij
1378
1379 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1380       evdw=0.0D0
1381       do i=iatsc_s,iatsc_e
1382         itypi=iabs(itype(i,1))
1383         if (itypi.eq.ntyp1) cycle
1384         itypi1=iabs(itype(i+1,1))
1385         xi=c(1,nres+i)
1386         yi=c(2,nres+i)
1387         zi=c(3,nres+i)
1388 !
1389 ! Calculate SC interaction energy.
1390 !
1391         do iint=1,nint_gr(i)
1392           do j=istart(i,iint),iend(i,iint)
1393             itypj=iabs(itype(j,1))
1394             if (itypj.eq.ntyp1) cycle
1395             xj=c(1,nres+j)-xi
1396             yj=c(2,nres+j)-yi
1397             zj=c(3,nres+j)-zi
1398             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1399             fac_augm=rrij**expon
1400             e_augm=augm(itypi,itypj)*fac_augm
1401             r_inv_ij=dsqrt(rrij)
1402             rij=1.0D0/r_inv_ij
1403             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1404             fac=r_shift_inv**expon
1405             e1=fac*fac*aa_aq(itypi,itypj)
1406             e2=fac*bb_aq(itypi,itypj)
1407             evdwij=e_augm+e1+e2
1408 !d          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1409 !d          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1410 !d          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1411 !d   &        restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
1412 !d   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1413 !d   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1414 !d   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1415             evdw=evdw+evdwij
1416 !
1417 ! Calculate the components of the gradient in DC and X
1418 !
1419             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1420             gg(1)=xj*fac
1421             gg(2)=yj*fac
1422             gg(3)=zj*fac
1423             do k=1,3
1424               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1425               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1426               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1427               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1428             enddo
1429 !grad            do k=i,j-1
1430 !grad              do l=1,3
1431 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1432 !grad              enddo
1433 !grad            enddo
1434           enddo      ! j
1435         enddo        ! iint
1436       enddo          ! i
1437       do i=1,nct
1438         do j=1,3
1439           gvdwc(j,i)=expon*gvdwc(j,i)
1440           gvdwx(j,i)=expon*gvdwx(j,i)
1441         enddo
1442       enddo
1443       return
1444       end subroutine eljk
1445 !-----------------------------------------------------------------------------
1446       subroutine ebp(evdw)
1447 !
1448 ! This subroutine calculates the interaction energy of nonbonded side chains
1449 ! assuming the Berne-Pechukas potential of interaction.
1450 !
1451       use comm_srutu
1452       use calc_data
1453 !      implicit real*8 (a-h,o-z)
1454 !      include 'DIMENSIONS'
1455 !      include 'COMMON.GEO'
1456 !      include 'COMMON.VAR'
1457 !      include 'COMMON.LOCAL'
1458 !      include 'COMMON.CHAIN'
1459 !      include 'COMMON.DERIV'
1460 !      include 'COMMON.NAMES'
1461 !      include 'COMMON.INTERACT'
1462 !      include 'COMMON.IOUNITS'
1463 !      include 'COMMON.CALC'
1464       use comm_srutu
1465 !el      integer :: icall
1466 !el      common /srutu/ icall
1467 !     double precision rrsave(maxdim)
1468       logical :: lprn
1469 !el local variables
1470       integer :: iint,itypi,itypi1,itypj
1471       real(kind=8) :: rrij,xi,yi,zi
1472       real(kind=8) :: evdw,fac,e1,e2,sigm,epsi
1473
1474 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1475       evdw=0.0D0
1476 !     if (icall.eq.0) then
1477 !       lprn=.true.
1478 !     else
1479         lprn=.false.
1480 !     endif
1481 !el      ind=0
1482       do i=iatsc_s,iatsc_e
1483         itypi=iabs(itype(i,1))
1484         if (itypi.eq.ntyp1) cycle
1485         itypi1=iabs(itype(i+1,1))
1486         xi=c(1,nres+i)
1487         yi=c(2,nres+i)
1488         zi=c(3,nres+i)
1489         dxi=dc_norm(1,nres+i)
1490         dyi=dc_norm(2,nres+i)
1491         dzi=dc_norm(3,nres+i)
1492 !        dsci_inv=dsc_inv(itypi)
1493         dsci_inv=vbld_inv(i+nres)
1494 !
1495 ! Calculate SC interaction energy.
1496 !
1497         do iint=1,nint_gr(i)
1498           do j=istart(i,iint),iend(i,iint)
1499 !el            ind=ind+1
1500             itypj=iabs(itype(j,1))
1501             if (itypj.eq.ntyp1) cycle
1502 !            dscj_inv=dsc_inv(itypj)
1503             dscj_inv=vbld_inv(j+nres)
1504             chi1=chi(itypi,itypj)
1505             chi2=chi(itypj,itypi)
1506             chi12=chi1*chi2
1507             chip1=chip(itypi)
1508             chip2=chip(itypj)
1509             chip12=chip1*chip2
1510             alf1=alp(itypi)
1511             alf2=alp(itypj)
1512             alf12=0.5D0*(alf1+alf2)
1513 ! For diagnostics only!!!
1514 !           chi1=0.0D0
1515 !           chi2=0.0D0
1516 !           chi12=0.0D0
1517 !           chip1=0.0D0
1518 !           chip2=0.0D0
1519 !           chip12=0.0D0
1520 !           alf1=0.0D0
1521 !           alf2=0.0D0
1522 !           alf12=0.0D0
1523             xj=c(1,nres+j)-xi
1524             yj=c(2,nres+j)-yi
1525             zj=c(3,nres+j)-zi
1526             dxj=dc_norm(1,nres+j)
1527             dyj=dc_norm(2,nres+j)
1528             dzj=dc_norm(3,nres+j)
1529             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1530 !d          if (icall.eq.0) then
1531 !d            rrsave(ind)=rrij
1532 !d          else
1533 !d            rrij=rrsave(ind)
1534 !d          endif
1535             rij=dsqrt(rrij)
1536 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
1537             call sc_angular
1538 ! Calculate whole angle-dependent part of epsilon and contributions
1539 ! to its derivatives
1540             fac=(rrij*sigsq)**expon2
1541             e1=fac*fac*aa_aq(itypi,itypj)
1542             e2=fac*bb_aq(itypi,itypj)
1543             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1544             eps2der=evdwij*eps3rt
1545             eps3der=evdwij*eps2rt
1546             evdwij=evdwij*eps2rt*eps3rt
1547             evdw=evdw+evdwij
1548             if (lprn) then
1549             sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
1550             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
1551 !d            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1552 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1553 !d     &        epsi,sigm,chi1,chi2,chip1,chip2,
1554 !d     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1555 !d     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1556 !d     &        evdwij
1557             endif
1558 ! Calculate gradient components.
1559             e1=e1*eps1*eps2rt**2*eps3rt**2
1560             fac=-expon*(e1+evdwij)
1561             sigder=fac/sigsq
1562             fac=rrij*fac
1563 ! Calculate radial part of the gradient
1564             gg(1)=xj*fac
1565             gg(2)=yj*fac
1566             gg(3)=zj*fac
1567 ! Calculate the angular part of the gradient and sum add the contributions
1568 ! to the appropriate components of the Cartesian gradient.
1569             call sc_grad
1570           enddo      ! j
1571         enddo        ! iint
1572       enddo          ! i
1573 !     stop
1574       return
1575       end subroutine ebp
1576 !-----------------------------------------------------------------------------
1577       subroutine egb(evdw)
1578 !
1579 ! This subroutine calculates the interaction energy of nonbonded side chains
1580 ! assuming the Gay-Berne potential of interaction.
1581 !
1582       use calc_data
1583 !      implicit real*8 (a-h,o-z)
1584 !      include 'DIMENSIONS'
1585 !      include 'COMMON.GEO'
1586 !      include 'COMMON.VAR'
1587 !      include 'COMMON.LOCAL'
1588 !      include 'COMMON.CHAIN'
1589 !      include 'COMMON.DERIV'
1590 !      include 'COMMON.NAMES'
1591 !      include 'COMMON.INTERACT'
1592 !      include 'COMMON.IOUNITS'
1593 !      include 'COMMON.CALC'
1594 !      include 'COMMON.CONTROL'
1595 !      include 'COMMON.SBRIDGE'
1596       logical :: lprn
1597 !el local variables
1598       integer :: iint,itypi,itypi1,itypj,subchap
1599       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
1600       real(kind=8) :: evdw,sig0ij
1601       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
1602                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
1603                     sslipi,sslipj,faclip
1604       integer :: ii
1605       real(kind=8) :: fracinbuf
1606
1607 !cccc      energy_dec=.false.
1608 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1609       evdw=0.0D0
1610       lprn=.false.
1611 !     if (icall.eq.0) lprn=.false.
1612 !el      ind=0
1613       do i=iatsc_s,iatsc_e
1614 !C        print *,"I am in EVDW",i
1615         itypi=iabs(itype(i,1))
1616 !        if (i.ne.47) cycle
1617         if (itypi.eq.ntyp1) cycle
1618         itypi1=iabs(itype(i+1,1))
1619         xi=c(1,nres+i)
1620         yi=c(2,nres+i)
1621         zi=c(3,nres+i)
1622           xi=dmod(xi,boxxsize)
1623           if (xi.lt.0) xi=xi+boxxsize
1624           yi=dmod(yi,boxysize)
1625           if (yi.lt.0) yi=yi+boxysize
1626           zi=dmod(zi,boxzsize)
1627           if (zi.lt.0) zi=zi+boxzsize
1628
1629        if ((zi.gt.bordlipbot)  &
1630         .and.(zi.lt.bordliptop)) then
1631 !C the energy transfer exist
1632         if (zi.lt.buflipbot) then
1633 !C what fraction I am in
1634          fracinbuf=1.0d0-  &
1635               ((zi-bordlipbot)/lipbufthick)
1636 !C lipbufthick is thickenes of lipid buffore
1637          sslipi=sscalelip(fracinbuf)
1638          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1639         elseif (zi.gt.bufliptop) then
1640          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1641          sslipi=sscalelip(fracinbuf)
1642          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1643         else
1644          sslipi=1.0d0
1645          ssgradlipi=0.0
1646         endif
1647        else
1648          sslipi=0.0d0
1649          ssgradlipi=0.0
1650        endif
1651 !       print *, sslipi,ssgradlipi
1652         dxi=dc_norm(1,nres+i)
1653         dyi=dc_norm(2,nres+i)
1654         dzi=dc_norm(3,nres+i)
1655 !        dsci_inv=dsc_inv(itypi)
1656         dsci_inv=vbld_inv(i+nres)
1657 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1658 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1659 !
1660 ! Calculate SC interaction energy.
1661 !
1662         do iint=1,nint_gr(i)
1663           do j=istart(i,iint),iend(i,iint)
1664             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1665               call dyn_ssbond_ene(i,j,evdwij)
1666               evdw=evdw+evdwij
1667               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1668                               'evdw',i,j,evdwij,' ss'
1669 !              if (energy_dec) write (iout,*) &
1670 !                              'evdw',i,j,evdwij,' ss'
1671              do k=j+1,iend(i,iint)
1672 !C search over all next residues
1673               if (dyn_ss_mask(k)) then
1674 !C check if they are cysteins
1675 !C              write(iout,*) 'k=',k
1676
1677 !c              write(iout,*) "PRZED TRI", evdwij
1678 !               evdwij_przed_tri=evdwij
1679               call triple_ssbond_ene(i,j,k,evdwij)
1680 !c               if(evdwij_przed_tri.ne.evdwij) then
1681 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1682 !c               endif
1683
1684 !c              write(iout,*) "PO TRI", evdwij
1685 !C call the energy function that removes the artifical triple disulfide
1686 !C bond the soubroutine is located in ssMD.F
1687               evdw=evdw+evdwij
1688               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
1689                             'evdw',i,j,evdwij,'tss'
1690               endif!dyn_ss_mask(k)
1691              enddo! k
1692             ELSE
1693 !el            ind=ind+1
1694             itypj=iabs(itype(j,1))
1695             if (itypj.eq.ntyp1) cycle
1696 !             if (j.ne.78) cycle
1697 !            dscj_inv=dsc_inv(itypj)
1698             dscj_inv=vbld_inv(j+nres)
1699 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,&
1700 !              1.0d0/vbld(j+nres) !d
1701 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
1702             sig0ij=sigma(itypi,itypj)
1703             chi1=chi(itypi,itypj)
1704             chi2=chi(itypj,itypi)
1705             chi12=chi1*chi2
1706             chip1=chip(itypi)
1707             chip2=chip(itypj)
1708             chip12=chip1*chip2
1709             alf1=alp(itypi)
1710             alf2=alp(itypj)
1711             alf12=0.5D0*(alf1+alf2)
1712 ! For diagnostics only!!!
1713 !           chi1=0.0D0
1714 !           chi2=0.0D0
1715 !           chi12=0.0D0
1716 !           chip1=0.0D0
1717 !           chip2=0.0D0
1718 !           chip12=0.0D0
1719 !           alf1=0.0D0
1720 !           alf2=0.0D0
1721 !           alf12=0.0D0
1722            xj=c(1,nres+j)
1723            yj=c(2,nres+j)
1724            zj=c(3,nres+j)
1725           xj=dmod(xj,boxxsize)
1726           if (xj.lt.0) xj=xj+boxxsize
1727           yj=dmod(yj,boxysize)
1728           if (yj.lt.0) yj=yj+boxysize
1729           zj=dmod(zj,boxzsize)
1730           if (zj.lt.0) zj=zj+boxzsize
1731 !          print *,"tu",xi,yi,zi,xj,yj,zj
1732 !          print *,"tu2",j,j+nres,c(1,j),c(1,j+nres)
1733 ! this fragment set correct epsilon for lipid phase
1734        if ((zj.gt.bordlipbot)  &
1735        .and.(zj.lt.bordliptop)) then
1736 !C the energy transfer exist
1737         if (zj.lt.buflipbot) then
1738 !C what fraction I am in
1739          fracinbuf=1.0d0-     &
1740              ((zj-bordlipbot)/lipbufthick)
1741 !C lipbufthick is thickenes of lipid buffore
1742          sslipj=sscalelip(fracinbuf)
1743          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1744         elseif (zj.gt.bufliptop) then
1745          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1746          sslipj=sscalelip(fracinbuf)
1747          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1748         else
1749          sslipj=1.0d0
1750          ssgradlipj=0.0
1751         endif
1752        else
1753          sslipj=0.0d0
1754          ssgradlipj=0.0
1755        endif
1756       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1757        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1758       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0   &
1759        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1760 !------------------------------------------------
1761       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1762       xj_safe=xj
1763       yj_safe=yj
1764       zj_safe=zj
1765       subchap=0
1766       do xshift=-1,1
1767       do yshift=-1,1
1768       do zshift=-1,1
1769           xj=xj_safe+xshift*boxxsize
1770           yj=yj_safe+yshift*boxysize
1771           zj=zj_safe+zshift*boxzsize
1772           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1773           if(dist_temp.lt.dist_init) then
1774             dist_init=dist_temp
1775             xj_temp=xj
1776             yj_temp=yj
1777             zj_temp=zj
1778             subchap=1
1779           endif
1780        enddo
1781        enddo
1782        enddo
1783        if (subchap.eq.1) then
1784           xj=xj_temp-xi
1785           yj=yj_temp-yi
1786           zj=zj_temp-zi
1787        else
1788           xj=xj_safe-xi
1789           yj=yj_safe-yi
1790           zj=zj_safe-zi
1791        endif
1792             dxj=dc_norm(1,nres+j)
1793             dyj=dc_norm(2,nres+j)
1794             dzj=dc_norm(3,nres+j)
1795 !            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1796 !            write (iout,*) "j",j," dc_norm",& !d
1797 !             dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1798 !          write(iout,*)"rrij ",rrij
1799 !          write(iout,*)"xj yj zj ", xj, yj, zj
1800 !          write(iout,*)"xi yi zi ", xi, yi, zi
1801 !          write(iout,*)"c ", c(1,:), c(2,:), c(3,:)
1802             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1803             rij=dsqrt(rrij)
1804             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
1805             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
1806 !            print *,sss_ele_cut,sss_ele_grad,&
1807 !            1.0d0/(rij),r_cut_ele,rlamb_ele
1808             if (sss_ele_cut.le.0.0) cycle
1809 ! Calculate angle-dependent terms of energy and contributions to their
1810 ! derivatives.
1811             call sc_angular
1812             sigsq=1.0D0/sigsq
1813             sig=sig0ij*dsqrt(sigsq)
1814             rij_shift=1.0D0/rij-sig+sig0ij
1815 !          write(iout,*)" rij_shift",rij_shift," rij",rij," sig",sig,&
1816 !            "sig0ij",sig0ij
1817 ! for diagnostics; uncomment
1818 !            rij_shift=1.2*sig0ij
1819 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1820             if (rij_shift.le.0.0D0) then
1821               evdw=1.0D20
1822 !d              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1823 !d     &        restyp(itypi,1),i,restyp(itypj,1),j,
1824 !d     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1825               return
1826             endif
1827             sigder=-sig*sigsq
1828 !---------------------------------------------------------------
1829             rij_shift=1.0D0/rij_shift
1830             fac=rij_shift**expon
1831             faclip=fac
1832             e1=fac*fac*aa!(itypi,itypj)
1833             e2=fac*bb!(itypi,itypj)
1834             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1835             eps2der=evdwij*eps3rt
1836             eps3der=evdwij*eps2rt
1837 !          write(iout,*)"aa, bb ",aa(:,:),bb(:,:)
1838 !          write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,& !d
1839 !          " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2," fac",fac !d
1840             evdwij=evdwij*eps2rt*eps3rt
1841             evdw=evdw+evdwij*sss_ele_cut
1842             if (lprn) then
1843             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1844             epsi=bb**2/aa!(itypi,itypj)
1845             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
1846               restyp(itypi,1),i,restyp(itypj,1),j, &
1847               epsi,sigm,chi1,chi2,chip1,chip2, &
1848               eps1,eps2rt**2,eps3rt**2,sig,sig0ij, &
1849               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift, &
1850               evdwij
1851             endif
1852
1853             if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2e10.2,e11.3)')&
1854                              'evdw',i,j,evdwij,xi,xj,rij !,"egb"
1855 !C             print *,i,j,c(1,i),c(1,j),c(2,i),c(2,j),c(3,i),c(3,j)
1856 !            if (energy_dec) write (iout,*) &
1857 !                             'evdw',i,j,evdwij
1858 !                       print *,"ZALAMKA", evdw
1859
1860 ! Calculate gradient components.
1861             e1=e1*eps1*eps2rt**2*eps3rt**2
1862             fac=-expon*(e1+evdwij)*rij_shift
1863             sigder=fac*sigder
1864             fac=rij*fac
1865 !            print *,'before fac',fac,rij,evdwij
1866             fac=fac+evdwij*sss_ele_grad/sss_ele_cut&
1867             /sigma(itypi,itypj)*rij
1868 !            print *,'grad part scale',fac,   &
1869 !             evdwij*sss_ele_grad/sss_ele_cut &
1870 !            /sigma(itypi,itypj)*rij
1871 !            fac=0.0d0
1872 ! Calculate the radial part of the gradient
1873             gg(1)=xj*fac
1874             gg(2)=yj*fac
1875             gg(3)=zj*fac
1876 !C Calculate the radial part of the gradient
1877             gg_lipi(3)=eps1*(eps2rt*eps2rt)&
1878        *(eps3rt*eps3rt)*sss_ele_cut/2.0d0*(faclip*faclip*&
1879         (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))&
1880        +faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1881             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1882             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1883
1884 !            print *,'before sc_grad', gg(1),gg(2),gg(3)
1885 ! Calculate angular part of the gradient.
1886             call sc_grad
1887             ENDIF    ! dyn_ss
1888           enddo      ! j
1889         enddo        ! iint
1890       enddo          ! i
1891 !       print *,"ZALAMKA", evdw
1892 !      write (iout,*) "Number of loop steps in EGB:",ind
1893 !ccc      energy_dec=.false.
1894       return
1895       end subroutine egb
1896 !-----------------------------------------------------------------------------
1897       subroutine egbv(evdw)
1898 !
1899 ! This subroutine calculates the interaction energy of nonbonded side chains
1900 ! assuming the Gay-Berne-Vorobjev potential of interaction.
1901 !
1902       use comm_srutu
1903       use calc_data
1904 !      implicit real*8 (a-h,o-z)
1905 !      include 'DIMENSIONS'
1906 !      include 'COMMON.GEO'
1907 !      include 'COMMON.VAR'
1908 !      include 'COMMON.LOCAL'
1909 !      include 'COMMON.CHAIN'
1910 !      include 'COMMON.DERIV'
1911 !      include 'COMMON.NAMES'
1912 !      include 'COMMON.INTERACT'
1913 !      include 'COMMON.IOUNITS'
1914 !      include 'COMMON.CALC'
1915       use comm_srutu
1916 !el      integer :: icall
1917 !el      common /srutu/ icall
1918       logical :: lprn
1919 !el local variables
1920       integer :: iint,itypi,itypi1,itypj
1921       real(kind=8) :: rrij,xi,yi,zi,r0ij,fac_augm,e_augm,fac,e1,e2,sigm
1922       real(kind=8) :: evdw,sig0ij,sig,rij_shift,epsi
1923
1924 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1925       evdw=0.0D0
1926       lprn=.false.
1927 !     if (icall.eq.0) lprn=.true.
1928 !el      ind=0
1929       do i=iatsc_s,iatsc_e
1930         itypi=iabs(itype(i,1))
1931         if (itypi.eq.ntyp1) cycle
1932         itypi1=iabs(itype(i+1,1))
1933         xi=c(1,nres+i)
1934         yi=c(2,nres+i)
1935         zi=c(3,nres+i)
1936         dxi=dc_norm(1,nres+i)
1937         dyi=dc_norm(2,nres+i)
1938         dzi=dc_norm(3,nres+i)
1939 !        dsci_inv=dsc_inv(itypi)
1940         dsci_inv=vbld_inv(i+nres)
1941 !
1942 ! Calculate SC interaction energy.
1943 !
1944         do iint=1,nint_gr(i)
1945           do j=istart(i,iint),iend(i,iint)
1946 !el            ind=ind+1
1947             itypj=iabs(itype(j,1))
1948             if (itypj.eq.ntyp1) cycle
1949 !            dscj_inv=dsc_inv(itypj)
1950             dscj_inv=vbld_inv(j+nres)
1951             sig0ij=sigma(itypi,itypj)
1952             r0ij=r0(itypi,itypj)
1953             chi1=chi(itypi,itypj)
1954             chi2=chi(itypj,itypi)
1955             chi12=chi1*chi2
1956             chip1=chip(itypi)
1957             chip2=chip(itypj)
1958             chip12=chip1*chip2
1959             alf1=alp(itypi)
1960             alf2=alp(itypj)
1961             alf12=0.5D0*(alf1+alf2)
1962 ! For diagnostics only!!!
1963 !           chi1=0.0D0
1964 !           chi2=0.0D0
1965 !           chi12=0.0D0
1966 !           chip1=0.0D0
1967 !           chip2=0.0D0
1968 !           chip12=0.0D0
1969 !           alf1=0.0D0
1970 !           alf2=0.0D0
1971 !           alf12=0.0D0
1972             xj=c(1,nres+j)-xi
1973             yj=c(2,nres+j)-yi
1974             zj=c(3,nres+j)-zi
1975             dxj=dc_norm(1,nres+j)
1976             dyj=dc_norm(2,nres+j)
1977             dzj=dc_norm(3,nres+j)
1978             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1979             rij=dsqrt(rrij)
1980 ! Calculate angle-dependent terms of energy and contributions to their
1981 ! derivatives.
1982             call sc_angular
1983             sigsq=1.0D0/sigsq
1984             sig=sig0ij*dsqrt(sigsq)
1985             rij_shift=1.0D0/rij-sig+r0ij
1986 ! I hate to put IF's in the loops, but here don't have another choice!!!!
1987             if (rij_shift.le.0.0D0) then
1988               evdw=1.0D20
1989               return
1990             endif
1991             sigder=-sig*sigsq
1992 !---------------------------------------------------------------
1993             rij_shift=1.0D0/rij_shift
1994             fac=rij_shift**expon
1995             e1=fac*fac*aa_aq(itypi,itypj)
1996             e2=fac*bb_aq(itypi,itypj)
1997             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1998             eps2der=evdwij*eps3rt
1999             eps3der=evdwij*eps2rt
2000             fac_augm=rrij**expon
2001             e_augm=augm(itypi,itypj)*fac_augm
2002             evdwij=evdwij*eps2rt*eps3rt
2003             evdw=evdw+evdwij+e_augm
2004             if (lprn) then
2005             sigm=dabs(aa_aq(itypi,itypj)/&
2006             bb_aq(itypi,itypj))**(1.0D0/6.0D0)
2007             epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
2008             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
2009               restyp(itypi,1),i,restyp(itypj,1),j,&
2010               epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
2011               chi1,chi2,chip1,chip2,&
2012               eps1,eps2rt**2,eps3rt**2,&
2013               om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
2014               evdwij+e_augm
2015             endif
2016 ! Calculate gradient components.
2017             e1=e1*eps1*eps2rt**2*eps3rt**2
2018             fac=-expon*(e1+evdwij)*rij_shift
2019             sigder=fac*sigder
2020             fac=rij*fac-2*expon*rrij*e_augm
2021 ! Calculate the radial part of the gradient
2022             gg(1)=xj*fac
2023             gg(2)=yj*fac
2024             gg(3)=zj*fac
2025 ! Calculate angular part of the gradient.
2026             call sc_grad
2027           enddo      ! j
2028         enddo        ! iint
2029       enddo          ! i
2030       end subroutine egbv
2031 !-----------------------------------------------------------------------------
2032 !el      subroutine sc_angular in module geometry
2033 !-----------------------------------------------------------------------------
2034       subroutine e_softsphere(evdw)
2035 !
2036 ! This subroutine calculates the interaction energy of nonbonded side chains
2037 ! assuming the LJ potential of interaction.
2038 !
2039 !      implicit real*8 (a-h,o-z)
2040 !      include 'DIMENSIONS'
2041       real(kind=8),parameter :: accur=1.0d-10
2042 !      include 'COMMON.GEO'
2043 !      include 'COMMON.VAR'
2044 !      include 'COMMON.LOCAL'
2045 !      include 'COMMON.CHAIN'
2046 !      include 'COMMON.DERIV'
2047 !      include 'COMMON.INTERACT'
2048 !      include 'COMMON.TORSION'
2049 !      include 'COMMON.SBRIDGE'
2050 !      include 'COMMON.NAMES'
2051 !      include 'COMMON.IOUNITS'
2052 !      include 'COMMON.CONTACTS'
2053       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
2054 !d    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2055 !el local variables
2056       integer :: i,iint,j,itypi,itypi1,itypj,k
2057       real(kind=8) :: evdw,xj,yj,zj,xi,yi,zi,rij,r0ij,r0ijsq,evdwij
2058       real(kind=8) :: fac
2059
2060       evdw=0.0D0
2061       do i=iatsc_s,iatsc_e
2062         itypi=iabs(itype(i,1))
2063         if (itypi.eq.ntyp1) cycle
2064         itypi1=iabs(itype(i+1,1))
2065         xi=c(1,nres+i)
2066         yi=c(2,nres+i)
2067         zi=c(3,nres+i)
2068 !
2069 ! Calculate SC interaction energy.
2070 !
2071         do iint=1,nint_gr(i)
2072 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2073 !d   &                  'iend=',iend(i,iint)
2074           do j=istart(i,iint),iend(i,iint)
2075             itypj=iabs(itype(j,1))
2076             if (itypj.eq.ntyp1) cycle
2077             xj=c(1,nres+j)-xi
2078             yj=c(2,nres+j)-yi
2079             zj=c(3,nres+j)-zi
2080             rij=xj*xj+yj*yj+zj*zj
2081 !           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2082             r0ij=r0(itypi,itypj)
2083             r0ijsq=r0ij*r0ij
2084 !            print *,i,j,r0ij,dsqrt(rij)
2085             if (rij.lt.r0ijsq) then
2086               evdwij=0.25d0*(rij-r0ijsq)**2
2087               fac=rij-r0ijsq
2088             else
2089               evdwij=0.0d0
2090               fac=0.0d0
2091             endif
2092             evdw=evdw+evdwij
2093 !
2094 ! Calculate the components of the gradient in DC and X
2095 !
2096             gg(1)=xj*fac
2097             gg(2)=yj*fac
2098             gg(3)=zj*fac
2099             do k=1,3
2100               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2101               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2102               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2103               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2104             enddo
2105 !grad            do k=i,j-1
2106 !grad              do l=1,3
2107 !grad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2108 !grad              enddo
2109 !grad            enddo
2110           enddo ! j
2111         enddo ! iint
2112       enddo ! i
2113       return
2114       end subroutine e_softsphere
2115 !-----------------------------------------------------------------------------
2116       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2117 !
2118 ! Soft-sphere potential of p-p interaction
2119 !
2120 !      implicit real*8 (a-h,o-z)
2121 !      include 'DIMENSIONS'
2122 !      include 'COMMON.CONTROL'
2123 !      include 'COMMON.IOUNITS'
2124 !      include 'COMMON.GEO'
2125 !      include 'COMMON.VAR'
2126 !      include 'COMMON.LOCAL'
2127 !      include 'COMMON.CHAIN'
2128 !      include 'COMMON.DERIV'
2129 !      include 'COMMON.INTERACT'
2130 !      include 'COMMON.CONTACTS'
2131 !      include 'COMMON.TORSION'
2132 !      include 'COMMON.VECTORS'
2133 !      include 'COMMON.FFIELD'
2134       real(kind=8),dimension(3) :: ggg
2135 !d      write(iout,*) 'In EELEC_soft_sphere'
2136 !el local variables
2137       integer :: i,j,k,num_conti,iteli,itelj
2138       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
2139       real(kind=8) :: dxi,dyi,dzi,xmedi,ymedi,zmedi,r0ij,r0ijsq
2140       real(kind=8) :: dxj,dyj,dzj,xj,yj,zj,rij,evdw1ij,fac
2141
2142       ees=0.0D0
2143       evdw1=0.0D0
2144       eel_loc=0.0d0
2145       eello_turn3=0.0d0
2146       eello_turn4=0.0d0
2147 !el      ind=0
2148       do i=iatel_s,iatel_e
2149         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
2150         dxi=dc(1,i)
2151         dyi=dc(2,i)
2152         dzi=dc(3,i)
2153         xmedi=c(1,i)+0.5d0*dxi
2154         ymedi=c(2,i)+0.5d0*dyi
2155         zmedi=c(3,i)+0.5d0*dzi
2156         num_conti=0
2157 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2158         do j=ielstart(i),ielend(i)
2159           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
2160 !el          ind=ind+1
2161           iteli=itel(i)
2162           itelj=itel(j)
2163           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2164           r0ij=rpp(iteli,itelj)
2165           r0ijsq=r0ij*r0ij
2166           dxj=dc(1,j)
2167           dyj=dc(2,j)
2168           dzj=dc(3,j)
2169           xj=c(1,j)+0.5D0*dxj-xmedi
2170           yj=c(2,j)+0.5D0*dyj-ymedi
2171           zj=c(3,j)+0.5D0*dzj-zmedi
2172           rij=xj*xj+yj*yj+zj*zj
2173           if (rij.lt.r0ijsq) then
2174             evdw1ij=0.25d0*(rij-r0ijsq)**2
2175             fac=rij-r0ijsq
2176           else
2177             evdw1ij=0.0d0
2178             fac=0.0d0
2179           endif
2180           evdw1=evdw1+evdw1ij
2181 !
2182 ! Calculate contributions to the Cartesian gradient.
2183 !
2184           ggg(1)=fac*xj
2185           ggg(2)=fac*yj
2186           ggg(3)=fac*zj
2187           do k=1,3
2188             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2189             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2190           enddo
2191 !
2192 ! Loop over residues i+1 thru j-1.
2193 !
2194 !grad          do k=i+1,j-1
2195 !grad            do l=1,3
2196 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
2197 !grad            enddo
2198 !grad          enddo
2199         enddo ! j
2200       enddo   ! i
2201 !grad      do i=nnt,nct-1
2202 !grad        do k=1,3
2203 !grad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2204 !grad        enddo
2205 !grad        do j=i+1,nct-1
2206 !grad          do k=1,3
2207 !grad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2208 !grad          enddo
2209 !grad        enddo
2210 !grad      enddo
2211       return
2212       end subroutine eelec_soft_sphere
2213 !-----------------------------------------------------------------------------
2214       subroutine vec_and_deriv
2215 !      implicit real*8 (a-h,o-z)
2216 !      include 'DIMENSIONS'
2217 #ifdef MPI
2218       include 'mpif.h'
2219 #endif
2220 !      include 'COMMON.IOUNITS'
2221 !      include 'COMMON.GEO'
2222 !      include 'COMMON.VAR'
2223 !      include 'COMMON.LOCAL'
2224 !      include 'COMMON.CHAIN'
2225 !      include 'COMMON.VECTORS'
2226 !      include 'COMMON.SETUP'
2227 !      include 'COMMON.TIME1'
2228       real(kind=8),dimension(3,3,2) :: uyder,uzder
2229       real(kind=8),dimension(2) :: vbld_inv_temp
2230 ! Compute the local reference systems. For reference system (i), the
2231 ! X-axis points from CA(i) to CA(i+1), the Y axis is in the
2232 ! CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2233 !el local variables
2234       integer :: i,j,k,l
2235       real(kind=8) :: facy,fac,costh
2236
2237 #ifdef PARVEC
2238       do i=ivec_start,ivec_end
2239 #else
2240       do i=1,nres-1
2241 #endif
2242           if (i.eq.nres-1) then
2243 ! Case of the last full residue
2244 ! Compute the Z-axis
2245             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2246             costh=dcos(pi-theta(nres))
2247             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2248             do k=1,3
2249               uz(k,i)=fac*uz(k,i)
2250             enddo
2251 ! Compute the derivatives of uz
2252             uzder(1,1,1)= 0.0d0
2253             uzder(2,1,1)=-dc_norm(3,i-1)
2254             uzder(3,1,1)= dc_norm(2,i-1)
2255             uzder(1,2,1)= dc_norm(3,i-1)
2256             uzder(2,2,1)= 0.0d0
2257             uzder(3,2,1)=-dc_norm(1,i-1)
2258             uzder(1,3,1)=-dc_norm(2,i-1)
2259             uzder(2,3,1)= dc_norm(1,i-1)
2260             uzder(3,3,1)= 0.0d0
2261             uzder(1,1,2)= 0.0d0
2262             uzder(2,1,2)= dc_norm(3,i)
2263             uzder(3,1,2)=-dc_norm(2,i)
2264             uzder(1,2,2)=-dc_norm(3,i)
2265             uzder(2,2,2)= 0.0d0
2266             uzder(3,2,2)= dc_norm(1,i)
2267             uzder(1,3,2)= dc_norm(2,i)
2268             uzder(2,3,2)=-dc_norm(1,i)
2269             uzder(3,3,2)= 0.0d0
2270 ! Compute the Y-axis
2271             facy=fac
2272             do k=1,3
2273               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2274             enddo
2275 ! Compute the derivatives of uy
2276             do j=1,3
2277               do k=1,3
2278                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i) &
2279                               -dc_norm(k,i)*dc_norm(j,i-1)
2280                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2281               enddo
2282               uyder(j,j,1)=uyder(j,j,1)-costh
2283               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2284             enddo
2285             do j=1,2
2286               do k=1,3
2287                 do l=1,3
2288                   uygrad(l,k,j,i)=uyder(l,k,j)
2289                   uzgrad(l,k,j,i)=uzder(l,k,j)
2290                 enddo
2291               enddo
2292             enddo
2293             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2294             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2295             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2296             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2297           else
2298 ! Other residues
2299 ! Compute the Z-axis
2300             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2301             costh=dcos(pi-theta(i+2))
2302             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2303             do k=1,3
2304               uz(k,i)=fac*uz(k,i)
2305             enddo
2306 ! Compute the derivatives of uz
2307             uzder(1,1,1)= 0.0d0
2308             uzder(2,1,1)=-dc_norm(3,i+1)
2309             uzder(3,1,1)= dc_norm(2,i+1)
2310             uzder(1,2,1)= dc_norm(3,i+1)
2311             uzder(2,2,1)= 0.0d0
2312             uzder(3,2,1)=-dc_norm(1,i+1)
2313             uzder(1,3,1)=-dc_norm(2,i+1)
2314             uzder(2,3,1)= dc_norm(1,i+1)
2315             uzder(3,3,1)= 0.0d0
2316             uzder(1,1,2)= 0.0d0
2317             uzder(2,1,2)= dc_norm(3,i)
2318             uzder(3,1,2)=-dc_norm(2,i)
2319             uzder(1,2,2)=-dc_norm(3,i)
2320             uzder(2,2,2)= 0.0d0
2321             uzder(3,2,2)= dc_norm(1,i)
2322             uzder(1,3,2)= dc_norm(2,i)
2323             uzder(2,3,2)=-dc_norm(1,i)
2324             uzder(3,3,2)= 0.0d0
2325 ! Compute the Y-axis
2326             facy=fac
2327             do k=1,3
2328               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2329             enddo
2330 ! Compute the derivatives of uy
2331             do j=1,3
2332               do k=1,3
2333                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i) &
2334                               -dc_norm(k,i)*dc_norm(j,i+1)
2335                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2336               enddo
2337               uyder(j,j,1)=uyder(j,j,1)-costh
2338               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2339             enddo
2340             do j=1,2
2341               do k=1,3
2342                 do l=1,3
2343                   uygrad(l,k,j,i)=uyder(l,k,j)
2344                   uzgrad(l,k,j,i)=uzder(l,k,j)
2345                 enddo
2346               enddo
2347             enddo
2348             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2349             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2350             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2351             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2352           endif
2353       enddo
2354       do i=1,nres-1
2355         vbld_inv_temp(1)=vbld_inv(i+1)
2356         if (i.lt.nres-1) then
2357           vbld_inv_temp(2)=vbld_inv(i+2)
2358           else
2359           vbld_inv_temp(2)=vbld_inv(i)
2360           endif
2361         do j=1,2
2362           do k=1,3
2363             do l=1,3
2364               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2365               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2366             enddo
2367           enddo
2368         enddo
2369       enddo
2370 #if defined(PARVEC) && defined(MPI)
2371       if (nfgtasks1.gt.1) then
2372         time00=MPI_Wtime()
2373 !        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2374 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2375 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2376         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),&
2377          MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2378          FG_COMM1,IERR)
2379         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),&
2380          MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,&
2381          FG_COMM1,IERR)
2382         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),&
2383          ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),&
2384          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2385         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),&
2386          ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),&
2387          ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2388         time_gather=time_gather+MPI_Wtime()-time00
2389       endif
2390 !      if (fg_rank.eq.0) then
2391 !        write (iout,*) "Arrays UY and UZ"
2392 !        do i=1,nres-1
2393 !          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2394 !     &     (uz(k,i),k=1,3)
2395 !        enddo
2396 !      endif
2397 #endif
2398       return
2399       end subroutine vec_and_deriv
2400 !-----------------------------------------------------------------------------
2401       subroutine check_vecgrad
2402 !      implicit real*8 (a-h,o-z)
2403 !      include 'DIMENSIONS'
2404 !      include 'COMMON.IOUNITS'
2405 !      include 'COMMON.GEO'
2406 !      include 'COMMON.VAR'
2407 !      include 'COMMON.LOCAL'
2408 !      include 'COMMON.CHAIN'
2409 !      include 'COMMON.VECTORS'
2410       real(kind=8),dimension(3,3,2,nres) :: uygradt,uzgradt      !(3,3,2,maxres)
2411       real(kind=8),dimension(3,nres) :: uyt,uzt      !(3,maxres)
2412       real(kind=8),dimension(3,3,2) :: uygradn,uzgradn
2413       real(kind=8),dimension(3) :: erij
2414       real(kind=8) :: delta=1.0d-7
2415 !el local variables
2416       integer :: i,j,k,l
2417
2418       call vec_and_deriv
2419 !d      do i=1,nres
2420 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2421 !rc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2422 !rc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2423 !d          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2424 !d     &     (dc_norm(if90,i),if90=1,3)
2425 !d          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2426 !d          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2427 !d          write(iout,'(a)')
2428 !d      enddo
2429       do i=1,nres
2430         do j=1,2
2431           do k=1,3
2432             do l=1,3
2433               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2434               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2435             enddo
2436           enddo
2437         enddo
2438       enddo
2439       call vec_and_deriv
2440       do i=1,nres
2441         do j=1,3
2442           uyt(j,i)=uy(j,i)
2443           uzt(j,i)=uz(j,i)
2444         enddo
2445       enddo
2446       do i=1,nres
2447 !d        write (iout,*) 'i=',i
2448         do k=1,3
2449           erij(k)=dc_norm(k,i)
2450         enddo
2451         do j=1,3
2452           do k=1,3
2453             dc_norm(k,i)=erij(k)
2454           enddo
2455           dc_norm(j,i)=dc_norm(j,i)+delta
2456 !          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2457 !          do k=1,3
2458 !            dc_norm(k,i)=dc_norm(k,i)/fac
2459 !          enddo
2460 !          write (iout,*) (dc_norm(k,i),k=1,3)
2461 !          write (iout,*) (erij(k),k=1,3)
2462           call vec_and_deriv
2463           do k=1,3
2464             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2465             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2466             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2467             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2468           enddo
2469 !          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2470 !     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2471 !     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2472         enddo
2473         do k=1,3
2474           dc_norm(k,i)=erij(k)
2475         enddo
2476 !d        do k=1,3
2477 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2478 !d     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2479 !d     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2480 !d          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2481 !d     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2482 !d     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2483 !d          write (iout,'(a)')
2484 !d        enddo
2485       enddo
2486       return
2487       end subroutine check_vecgrad
2488 !-----------------------------------------------------------------------------
2489       subroutine set_matrices
2490 !      implicit real*8 (a-h,o-z)
2491 !      include 'DIMENSIONS'
2492 #ifdef MPI
2493       include "mpif.h"
2494 !      include "COMMON.SETUP"
2495       integer :: IERR
2496       integer :: status(MPI_STATUS_SIZE)
2497 #endif
2498 !      include 'COMMON.IOUNITS'
2499 !      include 'COMMON.GEO'
2500 !      include 'COMMON.VAR'
2501 !      include 'COMMON.LOCAL'
2502 !      include 'COMMON.CHAIN'
2503 !      include 'COMMON.DERIV'
2504 !      include 'COMMON.INTERACT'
2505 !      include 'COMMON.CONTACTS'
2506 !      include 'COMMON.TORSION'
2507 !      include 'COMMON.VECTORS'
2508 !      include 'COMMON.FFIELD'
2509       real(kind=8) :: auxvec(2),auxmat(2,2)
2510       integer :: i,iti1,iti,k,l
2511       real(kind=8) :: sin1,cos1,sin2,cos2,dwacos2,dwasin2
2512 !       print *,"in set matrices"
2513 !
2514 ! Compute the virtual-bond-torsional-angle dependent quantities needed
2515 ! to calculate the el-loc multibody terms of various order.
2516 !
2517 !AL el      mu=0.0d0
2518 #ifdef PARMAT
2519       do i=ivec_start+2,ivec_end+2
2520 #else
2521       do i=3,nres+1
2522 #endif
2523 !      print *,i,"i"
2524         if (i .lt. nres+1) then
2525           sin1=dsin(phi(i))
2526           cos1=dcos(phi(i))
2527           sintab(i-2)=sin1
2528           costab(i-2)=cos1
2529           obrot(1,i-2)=cos1
2530           obrot(2,i-2)=sin1
2531           sin2=dsin(2*phi(i))
2532           cos2=dcos(2*phi(i))
2533           sintab2(i-2)=sin2
2534           costab2(i-2)=cos2
2535           obrot2(1,i-2)=cos2
2536           obrot2(2,i-2)=sin2
2537           Ug(1,1,i-2)=-cos1
2538           Ug(1,2,i-2)=-sin1
2539           Ug(2,1,i-2)=-sin1
2540           Ug(2,2,i-2)= cos1
2541           Ug2(1,1,i-2)=-cos2
2542           Ug2(1,2,i-2)=-sin2
2543           Ug2(2,1,i-2)=-sin2
2544           Ug2(2,2,i-2)= cos2
2545         else
2546           costab(i-2)=1.0d0
2547           sintab(i-2)=0.0d0
2548           obrot(1,i-2)=1.0d0
2549           obrot(2,i-2)=0.0d0
2550           obrot2(1,i-2)=0.0d0
2551           obrot2(2,i-2)=0.0d0
2552           Ug(1,1,i-2)=1.0d0
2553           Ug(1,2,i-2)=0.0d0
2554           Ug(2,1,i-2)=0.0d0
2555           Ug(2,2,i-2)=1.0d0
2556           Ug2(1,1,i-2)=0.0d0
2557           Ug2(1,2,i-2)=0.0d0
2558           Ug2(2,1,i-2)=0.0d0
2559           Ug2(2,2,i-2)=0.0d0
2560         endif
2561         if (i .gt. 3 .and. i .lt. nres+1) then
2562           obrot_der(1,i-2)=-sin1
2563           obrot_der(2,i-2)= cos1
2564           Ugder(1,1,i-2)= sin1
2565           Ugder(1,2,i-2)=-cos1
2566           Ugder(2,1,i-2)=-cos1
2567           Ugder(2,2,i-2)=-sin1
2568           dwacos2=cos2+cos2
2569           dwasin2=sin2+sin2
2570           obrot2_der(1,i-2)=-dwasin2
2571           obrot2_der(2,i-2)= dwacos2
2572           Ug2der(1,1,i-2)= dwasin2
2573           Ug2der(1,2,i-2)=-dwacos2
2574           Ug2der(2,1,i-2)=-dwacos2
2575           Ug2der(2,2,i-2)=-dwasin2
2576         else
2577           obrot_der(1,i-2)=0.0d0
2578           obrot_der(2,i-2)=0.0d0
2579           Ugder(1,1,i-2)=0.0d0
2580           Ugder(1,2,i-2)=0.0d0
2581           Ugder(2,1,i-2)=0.0d0
2582           Ugder(2,2,i-2)=0.0d0
2583           obrot2_der(1,i-2)=0.0d0
2584           obrot2_der(2,i-2)=0.0d0
2585           Ug2der(1,1,i-2)=0.0d0
2586           Ug2der(1,2,i-2)=0.0d0
2587           Ug2der(2,1,i-2)=0.0d0
2588           Ug2der(2,2,i-2)=0.0d0
2589         endif
2590 !        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2591         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2592            if (itype(i-2,1).eq.0) then
2593           iti=ntortyp+1
2594            else
2595           iti = itortyp(itype(i-2,1))
2596            endif
2597         else
2598           iti=ntortyp+1
2599         endif
2600 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2601         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2602            if (itype(i-1,1).eq.0) then
2603           iti1=ntortyp+1
2604            else
2605           iti1 = itortyp(itype(i-1,1))
2606            endif
2607         else
2608           iti1=ntortyp+1
2609         endif
2610 !          print *,iti,i,"iti",iti1,itype(i-1,1),itype(i-2,1)
2611 !d        write (iout,*) '*******i',i,' iti1',iti
2612 !d        write (iout,*) 'b1',b1(:,iti)
2613 !d        write (iout,*) 'b2',b2(:,iti)
2614 !d        write (iout,*) 'Ug',Ug(:,:,i-2)
2615 !        if (i .gt. iatel_s+2) then
2616         if (i .gt. nnt+2) then
2617           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2618           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2619           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2620           then
2621           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2622           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2623           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2624           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2625           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2626           endif
2627         else
2628           do k=1,2
2629             Ub2(k,i-2)=0.0d0
2630             Ctobr(k,i-2)=0.0d0
2631             Dtobr2(k,i-2)=0.0d0
2632             do l=1,2
2633               EUg(l,k,i-2)=0.0d0
2634               CUg(l,k,i-2)=0.0d0
2635               DUg(l,k,i-2)=0.0d0
2636               DtUg2(l,k,i-2)=0.0d0
2637             enddo
2638           enddo
2639         endif
2640         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2641         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2642         do k=1,2
2643           muder(k,i-2)=Ub2der(k,i-2)
2644         enddo
2645 !        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2646         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2647           if (itype(i-1,1).eq.0) then
2648            iti1=ntortyp+1
2649           elseif (itype(i-1,1).le.ntyp) then
2650             iti1 = itortyp(itype(i-1,1))
2651           else
2652             iti1=ntortyp+1
2653           endif
2654         else
2655           iti1=ntortyp+1
2656         endif
2657         do k=1,2
2658           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2659         enddo
2660 !        if (energy_dec) write (iout,*) 'Ub2 ',i,Ub2(:,i-2)
2661 !        if (energy_dec) write (iout,*) 'b1 ',iti1,b1(:,iti1)
2662 !        if (energy_dec) write (iout,*) 'mu ',i,iti1,mu(:,i-2)
2663 !d        write (iout,*) 'mu1',mu1(:,i-2)
2664 !d        write (iout,*) 'mu2',mu2(:,i-2)
2665         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2666         then
2667         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2668         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2669         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2670         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2671         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2672 ! Vectors and matrices dependent on a single virtual-bond dihedral.
2673         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2674         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2675         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2676         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2677         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2678         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2679         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2680         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2681         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2682         endif
2683       enddo
2684 ! Matrices dependent on two consecutive virtual-bond dihedrals.
2685 ! The order of matrices is from left to right.
2686       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0) &
2687       then
2688 !      do i=max0(ivec_start,2),ivec_end
2689       do i=2,nres-1
2690         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2691         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2692         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2693         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2694         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2695         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2696         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2697         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2698       enddo
2699       endif
2700 #if defined(MPI) && defined(PARMAT)
2701 #ifdef DEBUG
2702 !      if (fg_rank.eq.0) then
2703         write (iout,*) "Arrays UG and UGDER before GATHER"
2704         do i=1,nres-1
2705           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2706            ((ug(l,k,i),l=1,2),k=1,2),&
2707            ((ugder(l,k,i),l=1,2),k=1,2)
2708         enddo
2709         write (iout,*) "Arrays UG2 and UG2DER"
2710         do i=1,nres-1
2711           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2712            ((ug2(l,k,i),l=1,2),k=1,2),&
2713            ((ug2der(l,k,i),l=1,2),k=1,2)
2714         enddo
2715         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2716         do i=1,nres-1
2717           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2718            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2719            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2720         enddo
2721         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2722         do i=1,nres-1
2723           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2724            costab(i),sintab(i),costab2(i),sintab2(i)
2725         enddo
2726         write (iout,*) "Array MUDER"
2727         do i=1,nres-1
2728           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2729         enddo
2730 !      endif
2731 #endif
2732       if (nfgtasks.gt.1) then
2733         time00=MPI_Wtime()
2734 !        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2735 !     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2736 !     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2737 #ifdef MATGATHER
2738         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),&
2739          MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2740          FG_COMM1,IERR)
2741         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),&
2742          MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2743          FG_COMM1,IERR)
2744         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),&
2745          MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2746          FG_COMM1,IERR)
2747         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),&
2748          MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2749          FG_COMM1,IERR)
2750         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),&
2751          MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2752          FG_COMM1,IERR)
2753         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),&
2754          MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2755          FG_COMM1,IERR)
2756         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),&
2757          MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),&
2758          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2759         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),&
2760          MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),&
2761          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2762         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),&
2763          MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),&
2764          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2765         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),&
2766          MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),&
2767          MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2768         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2769         then
2770         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),&
2771          MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2772          FG_COMM1,IERR)
2773         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),&
2774          MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2775          FG_COMM1,IERR)
2776         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),&
2777          MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2778          FG_COMM1,IERR)
2779        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),&
2780          MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2781          FG_COMM1,IERR)
2782         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),&
2783          MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2784          FG_COMM1,IERR)
2785         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),&
2786          ivec_count(fg_rank1),&
2787          MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2788          FG_COMM1,IERR)
2789         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),&
2790          MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2791          FG_COMM1,IERR)
2792         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),&
2793          MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,&
2794          FG_COMM1,IERR)
2795         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),&
2796          MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2797          FG_COMM1,IERR)
2798         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),&
2799          MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2800          FG_COMM1,IERR)
2801         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),&
2802          MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2803          FG_COMM1,IERR)
2804         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),&
2805          MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2806          FG_COMM1,IERR)
2807         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),&
2808          MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2809          FG_COMM1,IERR)
2810         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),&
2811          ivec_count(fg_rank1),&
2812          MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2813          FG_COMM1,IERR)
2814         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),&
2815          MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2816          FG_COMM1,IERR)
2817        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),&
2818          MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2819          FG_COMM1,IERR)
2820         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),&
2821          MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2822          FG_COMM1,IERR)
2823        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),&
2824          MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2825          FG_COMM1,IERR)
2826         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),&
2827          ivec_count(fg_rank1),&
2828          MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2829          FG_COMM1,IERR)
2830         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),&
2831          ivec_count(fg_rank1),&
2832          MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,&
2833          FG_COMM1,IERR)
2834         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),&
2835          ivec_count(fg_rank1),&
2836          MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2837          MPI_MAT2,FG_COMM1,IERR)
2838         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),&
2839          ivec_count(fg_rank1),&
2840          MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),&
2841          MPI_MAT2,FG_COMM1,IERR)
2842         endif
2843 #else
2844 ! Passes matrix info through the ring
2845       isend=fg_rank1
2846       irecv=fg_rank1-1
2847       if (irecv.lt.0) irecv=nfgtasks1-1
2848       iprev=irecv
2849       inext=fg_rank1+1
2850       if (inext.ge.nfgtasks1) inext=0
2851       do i=1,nfgtasks1-1
2852 !        write (iout,*) "isend",isend," irecv",irecv
2853 !        call flush(iout)
2854         lensend=lentyp(isend)
2855         lenrecv=lentyp(irecv)
2856 !        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2857 !        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2858 !     &   MPI_ROTAT1(lensend),inext,2200+isend,
2859 !     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2860 !     &   iprev,2200+irecv,FG_COMM,status,IERR)
2861 !        write (iout,*) "Gather ROTAT1"
2862 !        call flush(iout)
2863 !        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2864 !     &   MPI_ROTAT2(lensend),inext,3300+isend,
2865 !     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2866 !     &   iprev,3300+irecv,FG_COMM,status,IERR)
2867 !        write (iout,*) "Gather ROTAT2"
2868 !        call flush(iout)
2869         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,&
2870          MPI_ROTAT_OLD(lensend),inext,4400+isend,&
2871          costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),&
2872          iprev,4400+irecv,FG_COMM,status,IERR)
2873 !        write (iout,*) "Gather ROTAT_OLD"
2874 !        call flush(iout)
2875         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,&
2876          MPI_PRECOMP11(lensend),inext,5500+isend,&
2877          mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),&
2878          iprev,5500+irecv,FG_COMM,status,IERR)
2879 !        write (iout,*) "Gather PRECOMP11"
2880 !        call flush(iout)
2881         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,&
2882          MPI_PRECOMP12(lensend),inext,6600+isend,&
2883          Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),&
2884          iprev,6600+irecv,FG_COMM,status,IERR)
2885 !        write (iout,*) "Gather PRECOMP12"
2886 !        call flush(iout)
2887         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) &
2888         then
2889         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,&
2890          MPI_ROTAT2(lensend),inext,7700+isend,&
2891          ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),&
2892          iprev,7700+irecv,FG_COMM,status,IERR)
2893 !        write (iout,*) "Gather PRECOMP21"
2894 !        call flush(iout)
2895         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,&
2896          MPI_PRECOMP22(lensend),inext,8800+isend,&
2897          EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),&
2898          iprev,8800+irecv,FG_COMM,status,IERR)
2899 !        write (iout,*) "Gather PRECOMP22"
2900 !        call flush(iout)
2901         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,&
2902          MPI_PRECOMP23(lensend),inext,9900+isend,&
2903          Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,&
2904          MPI_PRECOMP23(lenrecv),&
2905          iprev,9900+irecv,FG_COMM,status,IERR)
2906 !        write (iout,*) "Gather PRECOMP23"
2907 !        call flush(iout)
2908         endif
2909         isend=irecv
2910         irecv=irecv-1
2911         if (irecv.lt.0) irecv=nfgtasks1-1
2912       enddo
2913 #endif
2914         time_gather=time_gather+MPI_Wtime()-time00
2915       endif
2916 #ifdef DEBUG
2917 !      if (fg_rank.eq.0) then
2918         write (iout,*) "Arrays UG and UGDER"
2919         do i=1,nres-1
2920           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2921            ((ug(l,k,i),l=1,2),k=1,2),&
2922            ((ugder(l,k,i),l=1,2),k=1,2)
2923         enddo
2924         write (iout,*) "Arrays UG2 and UG2DER"
2925         do i=1,nres-1
2926           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2927            ((ug2(l,k,i),l=1,2),k=1,2),&
2928            ((ug2der(l,k,i),l=1,2),k=1,2)
2929         enddo
2930         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2931         do i=1,nres-1
2932           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2933            (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),&
2934            (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2935         enddo
2936         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2937         do i=1,nres-1
2938           write (iout,'(i5,4f10.5,5x,4f10.5)') i,&
2939            costab(i),sintab(i),costab2(i),sintab2(i)
2940         enddo
2941         write (iout,*) "Array MUDER"
2942         do i=1,nres-1
2943           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2944         enddo
2945 !      endif
2946 #endif
2947 #endif
2948 !d      do i=1,nres
2949 !d        iti = itortyp(itype(i,1))
2950 !d        write (iout,*) i
2951 !d        do j=1,2
2952 !d        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2953 !d     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2954 !d        enddo
2955 !d      enddo
2956       return
2957       end subroutine set_matrices
2958 !-----------------------------------------------------------------------------
2959       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2960 !
2961 ! This subroutine calculates the average interaction energy and its gradient
2962 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
2963 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2964 ! The potential depends both on the distance of peptide-group centers and on
2965 ! the orientation of the CA-CA virtual bonds.
2966 !
2967       use comm_locel
2968 !      implicit real*8 (a-h,o-z)
2969 #ifdef MPI
2970       include 'mpif.h'
2971 #endif
2972 !      include 'DIMENSIONS'
2973 !      include 'COMMON.CONTROL'
2974 !      include 'COMMON.SETUP'
2975 !      include 'COMMON.IOUNITS'
2976 !      include 'COMMON.GEO'
2977 !      include 'COMMON.VAR'
2978 !      include 'COMMON.LOCAL'
2979 !      include 'COMMON.CHAIN'
2980 !      include 'COMMON.DERIV'
2981 !      include 'COMMON.INTERACT'
2982 !      include 'COMMON.CONTACTS'
2983 !      include 'COMMON.TORSION'
2984 !      include 'COMMON.VECTORS'
2985 !      include 'COMMON.FFIELD'
2986 !      include 'COMMON.TIME1'
2987       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
2988       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
2989       real(kind=8),dimension(2,2) :: acipa !el,a_temp
2990 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
2991       real(kind=8),dimension(4) :: muij
2992 !el      integer :: num_conti,j1,j2
2993 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
2994 !el        dz_normi,xmedi,ymedi,zmedi
2995
2996 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
2997 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
2998 !el          num_conti,j1,j2
2999
3000 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3001 #ifdef MOMENT
3002       real(kind=8) :: scal_el=1.0d0
3003 #else
3004       real(kind=8) :: scal_el=0.5d0
3005 #endif
3006 ! 12/13/98
3007 ! 13-go grudnia roku pamietnego...
3008       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3009                                              0.0d0,1.0d0,0.0d0,&
3010                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3011 !el local variables
3012       integer :: i,k,j
3013       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
3014       real(kind=8) :: fac,t_eelecij,fracinbuf
3015
3016
3017 !d      write(iout,*) 'In EELEC'
3018 !        print *,"IN EELEC"
3019 !d      do i=1,nloctyp
3020 !d        write(iout,*) 'Type',i
3021 !d        write(iout,*) 'B1',B1(:,i)
3022 !d        write(iout,*) 'B2',B2(:,i)
3023 !d        write(iout,*) 'CC',CC(:,:,i)
3024 !d        write(iout,*) 'DD',DD(:,:,i)
3025 !d        write(iout,*) 'EE',EE(:,:,i)
3026 !d      enddo
3027 !d      call check_vecgrad
3028 !d      stop
3029 !      ees=0.0d0  !AS
3030 !      evdw1=0.0d0
3031 !      eel_loc=0.0d0
3032 !      eello_turn3=0.0d0
3033 !      eello_turn4=0.0d0
3034       t_eelecij=0.0d0
3035       ees=0.0D0
3036       evdw1=0.0D0
3037       eel_loc=0.0d0
3038       eello_turn3=0.0d0
3039       eello_turn4=0.0d0
3040 !
3041
3042       if (icheckgrad.eq.1) then
3043 !el
3044 !        do i=0,2*nres+2
3045 !          dc_norm(1,i)=0.0d0
3046 !          dc_norm(2,i)=0.0d0
3047 !          dc_norm(3,i)=0.0d0
3048 !        enddo
3049         do i=1,nres-1
3050           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3051           do k=1,3
3052             dc_norm(k,i)=dc(k,i)*fac
3053           enddo
3054 !          write (iout,*) 'i',i,' fac',fac
3055         enddo
3056       endif
3057 !      print *,wel_loc,"wel_loc",wcorr4,wcorr5,wcorr6,wturn3,wturn4,  &
3058 !        wturn6
3059       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3060           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
3061           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3062 !        call vec_and_deriv
3063 #ifdef TIMING
3064         time01=MPI_Wtime()
3065 #endif
3066 !        print *, "before set matrices"
3067         call set_matrices
3068 !        print *, "after set matrices"
3069
3070 #ifdef TIMING
3071         time_mat=time_mat+MPI_Wtime()-time01
3072 #endif
3073       endif
3074 !       print *, "after set matrices"
3075 !d      do i=1,nres-1
3076 !d        write (iout,*) 'i=',i
3077 !d        do k=1,3
3078 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3079 !d        enddo
3080 !d        do k=1,3
3081 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3082 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3083 !d        enddo
3084 !d      enddo
3085       t_eelecij=0.0d0
3086       ees=0.0D0
3087       evdw1=0.0D0
3088       eel_loc=0.0d0
3089       eello_turn3=0.0d0
3090       eello_turn4=0.0d0
3091 !el      ind=0
3092       do i=1,nres
3093         num_cont_hb(i)=0
3094       enddo
3095 !d      print '(a)','Enter EELEC'
3096 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3097 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
3098 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
3099       do i=1,nres
3100         gel_loc_loc(i)=0.0d0
3101         gcorr_loc(i)=0.0d0
3102       enddo
3103 !
3104 !
3105 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3106 !
3107 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
3108 !
3109
3110
3111 !        print *,"before iturn3 loop"
3112       do i=iturn3_start,iturn3_end
3113         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3114         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
3115         dxi=dc(1,i)
3116         dyi=dc(2,i)
3117         dzi=dc(3,i)
3118         dx_normi=dc_norm(1,i)
3119         dy_normi=dc_norm(2,i)
3120         dz_normi=dc_norm(3,i)
3121         xmedi=c(1,i)+0.5d0*dxi
3122         ymedi=c(2,i)+0.5d0*dyi
3123         zmedi=c(3,i)+0.5d0*dzi
3124           xmedi=dmod(xmedi,boxxsize)
3125           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3126           ymedi=dmod(ymedi,boxysize)
3127           if (ymedi.lt.0) ymedi=ymedi+boxysize
3128           zmedi=dmod(zmedi,boxzsize)
3129           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3130         num_conti=0
3131        if ((zmedi.gt.bordlipbot) &
3132         .and.(zmedi.lt.bordliptop)) then
3133 !C the energy transfer exist
3134         if (zmedi.lt.buflipbot) then
3135 !C what fraction I am in
3136          fracinbuf=1.0d0- &
3137                ((zmedi-bordlipbot)/lipbufthick)
3138 !C lipbufthick is thickenes of lipid buffore
3139          sslipi=sscalelip(fracinbuf)
3140          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3141         elseif (zmedi.gt.bufliptop) then
3142          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3143          sslipi=sscalelip(fracinbuf)
3144          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3145         else
3146          sslipi=1.0d0
3147          ssgradlipi=0.0
3148         endif
3149        else
3150          sslipi=0.0d0
3151          ssgradlipi=0.0
3152        endif
3153 !       print *,i,sslipi,ssgradlipi
3154        call eelecij(i,i+2,ees,evdw1,eel_loc)
3155         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3156         num_cont_hb(i)=num_conti
3157       enddo
3158       do i=iturn4_start,iturn4_end
3159         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
3160           .or. itype(i+3,1).eq.ntyp1 &
3161           .or. itype(i+4,1).eq.ntyp1) cycle
3162 !        print *,"before2",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3163         dxi=dc(1,i)
3164         dyi=dc(2,i)
3165         dzi=dc(3,i)
3166         dx_normi=dc_norm(1,i)
3167         dy_normi=dc_norm(2,i)
3168         dz_normi=dc_norm(3,i)
3169         xmedi=c(1,i)+0.5d0*dxi
3170         ymedi=c(2,i)+0.5d0*dyi
3171         zmedi=c(3,i)+0.5d0*dzi
3172           xmedi=dmod(xmedi,boxxsize)
3173           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3174           ymedi=dmod(ymedi,boxysize)
3175           if (ymedi.lt.0) ymedi=ymedi+boxysize
3176           zmedi=dmod(zmedi,boxzsize)
3177           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3178        if ((zmedi.gt.bordlipbot)  &
3179        .and.(zmedi.lt.bordliptop)) then
3180 !C the energy transfer exist
3181         if (zmedi.lt.buflipbot) then
3182 !C what fraction I am in
3183          fracinbuf=1.0d0- &
3184              ((zmedi-bordlipbot)/lipbufthick)
3185 !C lipbufthick is thickenes of lipid buffore
3186          sslipi=sscalelip(fracinbuf)
3187          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3188         elseif (zmedi.gt.bufliptop) then
3189          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3190          sslipi=sscalelip(fracinbuf)
3191          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3192         else
3193          sslipi=1.0d0
3194          ssgradlipi=0.0
3195         endif
3196        else
3197          sslipi=0.0d0
3198          ssgradlipi=0.0
3199        endif
3200
3201         num_conti=num_cont_hb(i)
3202         call eelecij(i,i+3,ees,evdw1,eel_loc)
3203         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
3204          call eturn4(i,eello_turn4)
3205 !        print *,"before",i,i+3, gshieldc_t4(2,i+3),gshieldc_t4(2,i)
3206         num_cont_hb(i)=num_conti
3207       enddo   ! i
3208 !
3209 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3210 !
3211 !      print *,"iatel_s,iatel_e,",iatel_s,iatel_e
3212       do i=iatel_s,iatel_e
3213         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
3214         dxi=dc(1,i)
3215         dyi=dc(2,i)
3216         dzi=dc(3,i)
3217         dx_normi=dc_norm(1,i)
3218         dy_normi=dc_norm(2,i)
3219         dz_normi=dc_norm(3,i)
3220         xmedi=c(1,i)+0.5d0*dxi
3221         ymedi=c(2,i)+0.5d0*dyi
3222         zmedi=c(3,i)+0.5d0*dzi
3223           xmedi=dmod(xmedi,boxxsize)
3224           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3225           ymedi=dmod(ymedi,boxysize)
3226           if (ymedi.lt.0) ymedi=ymedi+boxysize
3227           zmedi=dmod(zmedi,boxzsize)
3228           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3229        if ((zmedi.gt.bordlipbot)  &
3230         .and.(zmedi.lt.bordliptop)) then
3231 !C the energy transfer exist
3232         if (zmedi.lt.buflipbot) then
3233 !C what fraction I am in
3234          fracinbuf=1.0d0- &
3235              ((zmedi-bordlipbot)/lipbufthick)
3236 !C lipbufthick is thickenes of lipid buffore
3237          sslipi=sscalelip(fracinbuf)
3238          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
3239         elseif (zmedi.gt.bufliptop) then
3240          fracinbuf=1.0d0-((bordliptop-zmedi)/lipbufthick)
3241          sslipi=sscalelip(fracinbuf)
3242          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
3243         else
3244          sslipi=1.0d0
3245          ssgradlipi=0.0
3246         endif
3247        else
3248          sslipi=0.0d0
3249          ssgradlipi=0.0
3250        endif
3251
3252 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3253         num_conti=num_cont_hb(i)
3254         do j=ielstart(i),ielend(i)
3255 !          write (iout,*) i,j,itype(i,1),itype(j,1)
3256           if (itype(j,1).eq.ntyp1.or. itype(j+1,1).eq.ntyp1) cycle
3257           call eelecij(i,j,ees,evdw1,eel_loc)
3258         enddo ! j
3259         num_cont_hb(i)=num_conti
3260       enddo   ! i
3261 !      write (iout,*) "Number of loop steps in EELEC:",ind
3262 !d      do i=1,nres
3263 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
3264 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3265 !d      enddo
3266 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3267 !cc      eel_loc=eel_loc+eello_turn3
3268 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3269       return
3270       end subroutine eelec
3271 !-----------------------------------------------------------------------------
3272       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3273
3274       use comm_locel
3275 !      implicit real*8 (a-h,o-z)
3276 !      include 'DIMENSIONS'
3277 #ifdef MPI
3278       include "mpif.h"
3279 #endif
3280 !      include 'COMMON.CONTROL'
3281 !      include 'COMMON.IOUNITS'
3282 !      include 'COMMON.GEO'
3283 !      include 'COMMON.VAR'
3284 !      include 'COMMON.LOCAL'
3285 !      include 'COMMON.CHAIN'
3286 !      include 'COMMON.DERIV'
3287 !      include 'COMMON.INTERACT'
3288 !      include 'COMMON.CONTACTS'
3289 !      include 'COMMON.TORSION'
3290 !      include 'COMMON.VECTORS'
3291 !      include 'COMMON.FFIELD'
3292 !      include 'COMMON.TIME1'
3293       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
3294       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
3295       real(kind=8),dimension(2,2) :: acipa !el,a_temp
3296 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
3297       real(kind=8),dimension(4) :: muij
3298       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
3299                     dist_temp, dist_init,rlocshield,fracinbuf
3300       integer xshift,yshift,zshift,ilist,iresshield
3301 !el      integer :: num_conti,j1,j2
3302 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
3303 !el        dz_normi,xmedi,ymedi,zmedi
3304
3305 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
3306 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
3307 !el          num_conti,j1,j2
3308
3309 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3310 #ifdef MOMENT
3311       real(kind=8) :: scal_el=1.0d0
3312 #else
3313       real(kind=8) :: scal_el=0.5d0
3314 #endif
3315 ! 12/13/98
3316 ! 13-go grudnia roku pamietnego...
3317       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
3318                                              0.0d0,1.0d0,0.0d0,&
3319                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
3320 !      integer :: maxconts=nres/4
3321 !el local variables
3322       integer :: k,i,j,iteli,itelj,kkk,l,kkll,m,isubchap
3323       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp
3324       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i
3325       real(kind=8) :: dxj,dyj,dzj,dx_normj,dy_normj,dz_normj,xj,yj,zj,&
3326                   rij,r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,&
3327                   evdwij,el1,el2,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
3328                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
3329                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
3330                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
3331                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
3332                   ecosgp,ecosam,ecosbm,ecosgm,ghalf
3333 !      maxconts=nres/4
3334 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
3335 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
3336
3337 !          time00=MPI_Wtime()
3338 !d      write (iout,*) "eelecij",i,j
3339 !          ind=ind+1
3340           iteli=itel(i)
3341           itelj=itel(j)
3342           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3343           aaa=app(iteli,itelj)
3344           bbb=bpp(iteli,itelj)
3345           ael6i=ael6(iteli,itelj)
3346           ael3i=ael3(iteli,itelj)
3347           dxj=dc(1,j)
3348           dyj=dc(2,j)
3349           dzj=dc(3,j)
3350           dx_normj=dc_norm(1,j)
3351           dy_normj=dc_norm(2,j)
3352           dz_normj=dc_norm(3,j)
3353 !          xj=c(1,j)+0.5D0*dxj-xmedi
3354 !          yj=c(2,j)+0.5D0*dyj-ymedi
3355 !          zj=c(3,j)+0.5D0*dzj-zmedi
3356           xj=c(1,j)+0.5D0*dxj
3357           yj=c(2,j)+0.5D0*dyj
3358           zj=c(3,j)+0.5D0*dzj
3359           xj=mod(xj,boxxsize)
3360           if (xj.lt.0) xj=xj+boxxsize
3361           yj=mod(yj,boxysize)
3362           if (yj.lt.0) yj=yj+boxysize
3363           zj=mod(zj,boxzsize)
3364           if (zj.lt.0) zj=zj+boxzsize
3365        if ((zj.gt.bordlipbot)  &
3366        .and.(zj.lt.bordliptop)) then
3367 !C the energy transfer exist
3368         if (zj.lt.buflipbot) then
3369 !C what fraction I am in
3370          fracinbuf=1.0d0-     &
3371              ((zj-bordlipbot)/lipbufthick)
3372 !C lipbufthick is thickenes of lipid buffore
3373          sslipj=sscalelip(fracinbuf)
3374          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
3375         elseif (zj.gt.bufliptop) then
3376          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
3377          sslipj=sscalelip(fracinbuf)
3378          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
3379         else
3380          sslipj=1.0d0
3381          ssgradlipj=0.0
3382         endif
3383        else
3384          sslipj=0.0d0
3385          ssgradlipj=0.0
3386        endif
3387
3388       isubchap=0
3389       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3390       xj_safe=xj
3391       yj_safe=yj
3392       zj_safe=zj
3393       do xshift=-1,1
3394       do yshift=-1,1
3395       do zshift=-1,1
3396           xj=xj_safe+xshift*boxxsize
3397           yj=yj_safe+yshift*boxysize
3398           zj=zj_safe+zshift*boxzsize
3399           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3400           if(dist_temp.lt.dist_init) then
3401             dist_init=dist_temp
3402             xj_temp=xj
3403             yj_temp=yj
3404             zj_temp=zj
3405             isubchap=1
3406           endif
3407        enddo
3408        enddo
3409        enddo
3410        if (isubchap.eq.1) then
3411 !C          print *,i,j
3412           xj=xj_temp-xmedi
3413           yj=yj_temp-ymedi
3414           zj=zj_temp-zmedi
3415        else
3416           xj=xj_safe-xmedi
3417           yj=yj_safe-ymedi
3418           zj=zj_safe-zmedi
3419        endif
3420
3421           rij=xj*xj+yj*yj+zj*zj
3422           rrmij=1.0D0/rij
3423           rij=dsqrt(rij)
3424 !C            print *,xmedi,ymedi,zmedi,xj,yj,zj,boxxsize,rij
3425             sss_ele_cut=sscale_ele(rij)
3426             sss_ele_grad=sscagrad_ele(rij)
3427 !             sss_ele_cut=1.0d0
3428 !             sss_ele_grad=0.0d0
3429 !            print *,sss_ele_cut,sss_ele_grad,&
3430 !            (rij),r_cut_ele,rlamb_ele
3431 !            if (sss_ele_cut.le.0.0) go to 128
3432
3433           rmij=1.0D0/rij
3434           r3ij=rrmij*rmij
3435           r6ij=r3ij*r3ij
3436           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3437           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3438           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3439           fac=cosa-3.0D0*cosb*cosg
3440           ev1=aaa*r6ij*r6ij
3441 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3442           if (j.eq.i+2) ev1=scal_el*ev1
3443           ev2=bbb*r6ij
3444           fac3=ael6i*r6ij
3445           fac4=ael3i*r3ij
3446           evdwij=ev1+ev2
3447           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3448           el2=fac4*fac
3449 !          eesij=el1+el2
3450           if (shield_mode.gt.0) then
3451 !C          fac_shield(i)=0.4
3452 !C          fac_shield(j)=0.6
3453           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3454           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3455           eesij=(el1+el2)
3456           ees=ees+eesij*sss_ele_cut
3457 !C FOR NOW SHIELD IS NOT USED WITH LIPSCALE
3458 !C     &    *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3459           else
3460           fac_shield(i)=1.0
3461           fac_shield(j)=1.0
3462           eesij=(el1+el2)
3463           ees=ees+eesij   &
3464             *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)*sss_ele_cut
3465 !C          print *,"TUCC",(sslipi+sslipj)/2.0d0*lipscale**2+1.0d0
3466           endif
3467
3468 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
3469           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3470 !          ees=ees+eesij*sss_ele_cut
3471           evdw1=evdw1+evdwij*sss_ele_cut  &
3472            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3473 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3474 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3475 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3476 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
3477
3478           if (energy_dec) then
3479 !              write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)') &
3480 !                  'evdw1',i,j,evdwij,&
3481 !                  iteli,itelj,aaa,evdw1
3482               write (iout,'(a6,2i5,0pf7.3)') 'evdw1',i,j,evdwij
3483               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
3484           endif
3485 !
3486 ! Calculate contributions to the Cartesian gradient.
3487 !
3488 #ifdef SPLITELE
3489           facvdw=-6*rrmij*(ev1+evdwij)*sss_ele_cut &
3490               *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3491           facel=-3*rrmij*(el1+eesij)*sss_ele_cut   &
3492              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3493           fac1=fac
3494           erij(1)=xj*rmij
3495           erij(2)=yj*rmij
3496           erij(3)=zj*rmij
3497 !
3498 ! Radial derivatives. First process both termini of the fragment (i,j)
3499 !
3500           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj* &
3501           ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3502           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj* &
3503            ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3504           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj* &
3505             ((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3506
3507           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
3508           (shield_mode.gt.0)) then
3509 !C          print *,i,j
3510           do ilist=1,ishield_list(i)
3511            iresshield=shield_list(ilist,i)
3512            do k=1,3
3513            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)&
3514            *2.0*sss_ele_cut
3515            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3516                    rlocshield &
3517             +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0 &
3518             *sss_ele_cut
3519             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3520            enddo
3521           enddo
3522           do ilist=1,ishield_list(j)
3523            iresshield=shield_list(ilist,j)
3524            do k=1,3
3525            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j) &
3526           *2.0*sss_ele_cut
3527            gshieldx(k,iresshield)=gshieldx(k,iresshield)+ &
3528                    rlocshield &
3529            +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0 &
3530            *sss_ele_cut
3531            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3532            enddo
3533           enddo
3534           do k=1,3
3535             gshieldc(k,i)=gshieldc(k,i)+ &
3536                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3537            *sss_ele_cut
3538
3539             gshieldc(k,j)=gshieldc(k,j)+ &
3540                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3541            *sss_ele_cut
3542
3543             gshieldc(k,i-1)=gshieldc(k,i-1)+ &
3544                    grad_shield(k,i)*eesij/fac_shield(i)*2.0 &
3545            *sss_ele_cut
3546
3547             gshieldc(k,j-1)=gshieldc(k,j-1)+ &
3548                    grad_shield(k,j)*eesij/fac_shield(j)*2.0 &
3549            *sss_ele_cut
3550
3551            enddo
3552            endif
3553
3554
3555 !          do k=1,3
3556 !            ghalf=0.5D0*ggg(k)
3557 !            gelc(k,i)=gelc(k,i)+ghalf
3558 !            gelc(k,j)=gelc(k,j)+ghalf
3559 !          enddo
3560 ! 9/28/08 AL Gradient compotents will be summed only at the end
3561           do k=1,3
3562             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3563             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3564           enddo
3565             gelc_long(3,j)=gelc_long(3,j)+  &
3566           ssgradlipj*eesij/2.0d0*lipscale**2&
3567            *sss_ele_cut
3568
3569             gelc_long(3,i)=gelc_long(3,i)+  &
3570           ssgradlipi*eesij/2.0d0*lipscale**2&
3571            *sss_ele_cut
3572
3573
3574 !
3575 ! Loop over residues i+1 thru j-1.
3576 !
3577 !grad          do k=i+1,j-1
3578 !grad            do l=1,3
3579 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3580 !grad            enddo
3581 !grad          enddo
3582           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj &
3583            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3584           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj &
3585            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3586           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj &
3587            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3588
3589 !          do k=1,3
3590 !            ghalf=0.5D0*ggg(k)
3591 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3592 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3593 !          enddo
3594 ! 9/28/08 AL Gradient compotents will be summed only at the end
3595           do k=1,3
3596             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3597             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3598           enddo
3599
3600 !C Lipidic part for scaling weight
3601            gvdwpp(3,j)=gvdwpp(3,j)+ &
3602           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3603            gvdwpp(3,i)=gvdwpp(3,i)+ &
3604           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3605 !! Loop over residues i+1 thru j-1.
3606 !
3607 !grad          do k=i+1,j-1
3608 !grad            do l=1,3
3609 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3610 !grad            enddo
3611 !grad          enddo
3612 #else
3613           facvdw=(ev1+evdwij)*sss_ele_cut &
3614            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3615
3616           facel=(el1+eesij)*sss_ele_cut
3617           fac1=fac
3618           fac=-3*rrmij*(facvdw+facvdw+facel)
3619           erij(1)=xj*rmij
3620           erij(2)=yj*rmij
3621           erij(3)=zj*rmij
3622 !
3623 ! Radial derivatives. First process both termini of the fragment (i,j)
3624 !
3625           ggg(1)=fac*xj+sss_ele_grad*rmij*(eesij+evdwij)*xj
3626           ggg(2)=fac*yj+sss_ele_grad*rmij*(eesij+evdwij)*yj
3627           ggg(3)=fac*zj+sss_ele_grad*rmij*(eesij+evdwij)*zj
3628 !          do k=1,3
3629 !            ghalf=0.5D0*ggg(k)
3630 !            gelc(k,i)=gelc(k,i)+ghalf
3631 !            gelc(k,j)=gelc(k,j)+ghalf
3632 !          enddo
3633 ! 9/28/08 AL Gradient compotents will be summed only at the end
3634           do k=1,3
3635             gelc_long(k,j)=gelc(k,j)+ggg(k)
3636             gelc_long(k,i)=gelc(k,i)-ggg(k)
3637           enddo
3638 !
3639 ! Loop over residues i+1 thru j-1.
3640 !
3641 !grad          do k=i+1,j-1
3642 !grad            do l=1,3
3643 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3644 !grad            enddo
3645 !grad          enddo
3646 ! 9/28/08 AL Gradient compotents will be summed only at the end
3647           ggg(1)=facvdw*xj &
3648            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3649           ggg(2)=facvdw*yj &
3650            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3651           ggg(3)=facvdw*zj &
3652            *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3653
3654           do k=1,3
3655             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3656             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3657           enddo
3658            gvdwpp(3,j)=gvdwpp(3,j)+ &
3659           sss_ele_cut*ssgradlipj*evdwij/2.0d0*lipscale**2
3660            gvdwpp(3,i)=gvdwpp(3,i)+ &
3661           sss_ele_cut*ssgradlipi*evdwij/2.0d0*lipscale**2
3662
3663 #endif
3664 !
3665 ! Angular part
3666 !
3667           ecosa=2.0D0*fac3*fac1+fac4
3668           fac4=-3.0D0*fac4
3669           fac3=-6.0D0*fac3
3670           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3671           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3672           do k=1,3
3673             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3674             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3675           enddo
3676 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3677 !d   &          (dcosg(k),k=1,3)
3678           do k=1,3
3679             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*sss_ele_cut &
3680              *fac_shield(i)**2*fac_shield(j)**2 &
3681              *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3682
3683           enddo
3684 !          do k=1,3
3685 !            ghalf=0.5D0*ggg(k)
3686 !            gelc(k,i)=gelc(k,i)+ghalf
3687 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3688 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3689 !            gelc(k,j)=gelc(k,j)+ghalf
3690 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3691 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3692 !          enddo
3693 !grad          do k=i+1,j-1
3694 !grad            do l=1,3
3695 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
3696 !grad            enddo
3697 !grad          enddo
3698           do k=1,3
3699             gelc(k,i)=gelc(k,i) &
3700                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
3701                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
3702                      *sss_ele_cut &
3703                      *fac_shield(i)**2*fac_shield(j)**2 &
3704                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3705
3706             gelc(k,j)=gelc(k,j) &
3707                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
3708                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
3709                      *sss_ele_cut  &
3710                      *fac_shield(i)**2*fac_shield(j)**2  &
3711                      *((sslipi+sslipj)/2.0d0*lipscale**2+1.0d0)
3712
3713             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3714             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3715           enddo
3716
3717           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
3718               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
3719               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3720 !
3721 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3722 !   energy of a peptide unit is assumed in the form of a second-order
3723 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3724 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3725 !   are computed for EVERY pair of non-contiguous peptide groups.
3726 !
3727           if (j.lt.nres-1) then
3728             j1=j+1
3729             j2=j-1
3730           else
3731             j1=j-1
3732             j2=j-2
3733           endif
3734           kkk=0
3735           do k=1,2
3736             do l=1,2
3737               kkk=kkk+1
3738               muij(kkk)=mu(k,i)*mu(l,j)
3739             enddo
3740           enddo
3741 !d         write (iout,*) 'EELEC: i',i,' j',j
3742 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
3743 !d          write(iout,*) 'muij',muij
3744           ury=scalar(uy(1,i),erij)
3745           urz=scalar(uz(1,i),erij)
3746           vry=scalar(uy(1,j),erij)
3747           vrz=scalar(uz(1,j),erij)
3748           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3749           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3750           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3751           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3752           fac=dsqrt(-ael6i)*r3ij
3753           a22=a22*fac
3754           a23=a23*fac
3755           a32=a32*fac
3756           a33=a33*fac
3757 !d          write (iout,'(4i5,4f10.5)')
3758 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
3759 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3760 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3761 !d     &      uy(:,j),uz(:,j)
3762 !d          write (iout,'(4f10.5)')
3763 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3764 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3765 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
3766 !d           write (iout,'(9f10.5/)')
3767 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3768 ! Derivatives of the elements of A in virtual-bond vectors
3769           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3770           do k=1,3
3771             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3772             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3773             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3774             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3775             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3776             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3777             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3778             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3779             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3780             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3781             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3782             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3783           enddo
3784 ! Compute radial contributions to the gradient
3785           facr=-3.0d0*rrmij
3786           a22der=a22*facr
3787           a23der=a23*facr
3788           a32der=a32*facr
3789           a33der=a33*facr
3790           agg(1,1)=a22der*xj
3791           agg(2,1)=a22der*yj
3792           agg(3,1)=a22der*zj
3793           agg(1,2)=a23der*xj
3794           agg(2,2)=a23der*yj
3795           agg(3,2)=a23der*zj
3796           agg(1,3)=a32der*xj
3797           agg(2,3)=a32der*yj
3798           agg(3,3)=a32der*zj
3799           agg(1,4)=a33der*xj
3800           agg(2,4)=a33der*yj
3801           agg(3,4)=a33der*zj
3802 ! Add the contributions coming from er
3803           fac3=-3.0d0*fac
3804           do k=1,3
3805             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3806             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3807             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3808             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3809           enddo
3810           do k=1,3
3811 ! Derivatives in DC(i)
3812 !grad            ghalf1=0.5d0*agg(k,1)
3813 !grad            ghalf2=0.5d0*agg(k,2)
3814 !grad            ghalf3=0.5d0*agg(k,3)
3815 !grad            ghalf4=0.5d0*agg(k,4)
3816             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
3817             -3.0d0*uryg(k,2)*vry)!+ghalf1
3818             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
3819             -3.0d0*uryg(k,2)*vrz)!+ghalf2
3820             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
3821             -3.0d0*urzg(k,2)*vry)!+ghalf3
3822             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
3823             -3.0d0*urzg(k,2)*vrz)!+ghalf4
3824 ! Derivatives in DC(i+1)
3825             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
3826             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3827             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
3828             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3829             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
3830             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3831             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
3832             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3833 ! Derivatives in DC(j)
3834             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
3835             -3.0d0*vryg(k,2)*ury)!+ghalf1
3836             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
3837             -3.0d0*vrzg(k,2)*ury)!+ghalf2
3838             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
3839             -3.0d0*vryg(k,2)*urz)!+ghalf3
3840             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
3841             -3.0d0*vrzg(k,2)*urz)!+ghalf4
3842 ! Derivatives in DC(j+1) or DC(nres-1)
3843             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
3844             -3.0d0*vryg(k,3)*ury)
3845             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
3846             -3.0d0*vrzg(k,3)*ury)
3847             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
3848             -3.0d0*vryg(k,3)*urz)
3849             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
3850             -3.0d0*vrzg(k,3)*urz)
3851 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
3852 !grad              do l=1,4
3853 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3854 !grad              enddo
3855 !grad            endif
3856           enddo
3857           acipa(1,1)=a22
3858           acipa(1,2)=a23
3859           acipa(2,1)=a32
3860           acipa(2,2)=a33
3861           a22=-a22
3862           a23=-a23
3863           do l=1,2
3864             do k=1,3
3865               agg(k,l)=-agg(k,l)
3866               aggi(k,l)=-aggi(k,l)
3867               aggi1(k,l)=-aggi1(k,l)
3868               aggj(k,l)=-aggj(k,l)
3869               aggj1(k,l)=-aggj1(k,l)
3870             enddo
3871           enddo
3872           if (j.lt.nres-1) then
3873             a22=-a22
3874             a32=-a32
3875             do l=1,3,2
3876               do k=1,3
3877                 agg(k,l)=-agg(k,l)
3878                 aggi(k,l)=-aggi(k,l)
3879                 aggi1(k,l)=-aggi1(k,l)
3880                 aggj(k,l)=-aggj(k,l)
3881                 aggj1(k,l)=-aggj1(k,l)
3882               enddo
3883             enddo
3884           else
3885             a22=-a22
3886             a23=-a23
3887             a32=-a32
3888             a33=-a33
3889             do l=1,4
3890               do k=1,3
3891                 agg(k,l)=-agg(k,l)
3892                 aggi(k,l)=-aggi(k,l)
3893                 aggi1(k,l)=-aggi1(k,l)
3894                 aggj(k,l)=-aggj(k,l)
3895                 aggj1(k,l)=-aggj1(k,l)
3896               enddo
3897             enddo
3898           endif
3899           ENDIF ! WCORR
3900           IF (wel_loc.gt.0.0d0) THEN
3901 ! Contribution to the local-electrostatic energy coming from the i-j pair
3902           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
3903            +a33*muij(4)
3904           if (shield_mode.eq.0) then
3905            fac_shield(i)=1.0
3906            fac_shield(j)=1.0
3907           endif
3908           eel_loc_ij=eel_loc_ij &
3909          *fac_shield(i)*fac_shield(j) &
3910          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3911 !C Now derivative over eel_loc
3912           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.  &
3913          (shield_mode.gt.0)) then
3914 !C          print *,i,j
3915
3916           do ilist=1,ishield_list(i)
3917            iresshield=shield_list(ilist,i)
3918            do k=1,3
3919            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij  &
3920                                                 /fac_shield(i)&
3921            *sss_ele_cut
3922            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3923                    rlocshield  &
3924           +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)  &
3925           *sss_ele_cut
3926
3927             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3928            +rlocshield
3929            enddo
3930           enddo
3931           do ilist=1,ishield_list(j)
3932            iresshield=shield_list(ilist,j)
3933            do k=1,3
3934            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij &
3935                                             /fac_shield(j)   &
3936             *sss_ele_cut
3937            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+ &
3938                    rlocshield  &
3939       +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)      &
3940        *sss_ele_cut
3941
3942            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)&
3943                   +rlocshield
3944
3945            enddo
3946           enddo
3947
3948           do k=1,3
3949             gshieldc_ll(k,i)=gshieldc_ll(k,i)+  &
3950                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3951                     *sss_ele_cut
3952             gshieldc_ll(k,j)=gshieldc_ll(k,j)+ &
3953                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3954                     *sss_ele_cut
3955             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+ &
3956                    grad_shield(k,i)*eel_loc_ij/fac_shield(i) &
3957                     *sss_ele_cut
3958             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+ &
3959                    grad_shield(k,j)*eel_loc_ij/fac_shield(j) &
3960                     *sss_ele_cut
3961
3962            enddo
3963            endif
3964
3965
3966 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3967 !           eel_loc_ij=0.0
3968 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
3969 !                  'eelloc',i,j,eel_loc_ij
3970           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,8f8.3)') &
3971                   'eelloc',i,j,eel_loc_ij,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
3972 !           print *,"EELLOC",i,gel_loc_loc(i-1)
3973
3974 !          if (energy_dec) write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
3975 !          if (energy_dec) write (iout,*) "muij",muij
3976 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3977
3978           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
3979 ! Partial derivatives in virtual-bond dihedral angles gamma
3980           if (i.gt.1) &
3981           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
3982                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
3983                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
3984                  *sss_ele_cut  &
3985           *fac_shield(i)*fac_shield(j) &
3986           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3987
3988           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
3989                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
3990                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
3991                  *sss_ele_cut &
3992           *fac_shield(i)*fac_shield(j) &
3993           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
3994 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3995 !          do l=1,3
3996 !            ggg(1)=(agg(1,1)*muij(1)+ &
3997 !                agg(1,2)*muij(2)+agg(1,3)*muij(3)+agg(1,4)*muij(4)) &
3998 !            *sss_ele_cut &
3999 !             +eel_loc_ij*sss_ele_grad*rmij*xj
4000 !            ggg(2)=(agg(2,1)*muij(1)+ &
4001 !                agg(2,2)*muij(2)+agg(2,3)*muij(3)+agg(2,4)*muij(4)) &
4002 !            *sss_ele_cut &
4003 !             +eel_loc_ij*sss_ele_grad*rmij*yj
4004 !            ggg(3)=(agg(3,1)*muij(1)+ &
4005 !                agg(3,2)*muij(2)+agg(3,3)*muij(3)+agg(3,4)*muij(4)) &
4006 !            *sss_ele_cut &
4007 !             +eel_loc_ij*sss_ele_grad*rmij*zj
4008            xtemp(1)=xj
4009            xtemp(2)=yj
4010            xtemp(3)=zj
4011
4012            do l=1,3
4013             ggg(l)=(agg(l,1)*muij(1)+ &
4014                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
4015             *sss_ele_cut &
4016           *fac_shield(i)*fac_shield(j) &
4017           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0) &
4018              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4019
4020
4021             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4022             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4023 !grad            ghalf=0.5d0*ggg(l)
4024 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4025 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4026           enddo
4027             gel_loc_long(3,j)=gel_loc_long(3,j)+ &
4028           ssgradlipj*eel_loc_ij/2.0d0*lipscale/  &
4029           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4030
4031             gel_loc_long(3,i)=gel_loc_long(3,i)+ &
4032           ssgradlipi*eel_loc_ij/2.0d0*lipscale/  &
4033           ((sslipi+sslipj)/2.0d0*lipscale+1.0d0)*sss_ele_cut
4034
4035 !grad          do k=i+1,j2
4036 !grad            do l=1,3
4037 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4038 !grad            enddo
4039 !grad          enddo
4040 ! Remaining derivatives of eello
4041           do l=1,3
4042             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
4043                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
4044             *sss_ele_cut &
4045           *fac_shield(i)*fac_shield(j) &
4046           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4047
4048 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4049             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
4050                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3) &
4051             +aggi1(l,4)*muij(4))&
4052             *sss_ele_cut &
4053           *fac_shield(i)*fac_shield(j) &
4054           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4055
4056 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4057             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
4058                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
4059             *sss_ele_cut &
4060           *fac_shield(i)*fac_shield(j) &
4061           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4062
4063 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4064             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
4065                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3) &
4066             +aggj1(l,4)*muij(4))&
4067             *sss_ele_cut &
4068           *fac_shield(i)*fac_shield(j) &
4069          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4070
4071 !+eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
4072           enddo
4073           ENDIF
4074 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
4075 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4076           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
4077              .and. num_conti.le.maxconts) then
4078 !            write (iout,*) i,j," entered corr"
4079 !
4080 ! Calculate the contact function. The ith column of the array JCONT will
4081 ! contain the numbers of atoms that make contacts with the atom I (of numbers
4082 ! greater than I). The arrays FACONT and GACONT will contain the values of
4083 ! the contact function and its derivative.
4084 !           r0ij=1.02D0*rpp(iteli,itelj)
4085 !           r0ij=1.11D0*rpp(iteli,itelj)
4086             r0ij=2.20D0*rpp(iteli,itelj)
4087 !           r0ij=1.55D0*rpp(iteli,itelj)
4088             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4089 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
4090             if (fcont.gt.0.0D0) then
4091               num_conti=num_conti+1
4092               if (num_conti.gt.maxconts) then
4093 !el                write (iout,*) "esrgresgdsrgdfsrgdswrgaresfgaerwgae"
4094 !el                write (iout,*) "num_conti",num_conti, "maxconts",maxconts
4095                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
4096                                ' will skip next contacts for this conf.', num_conti
4097               else
4098                 jcont_hb(num_conti,i)=j
4099 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
4100 !d     &           " jcont_hb",jcont_hb(num_conti,i)
4101                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
4102                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4103 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4104 !  terms.
4105                 d_cont(num_conti,i)=rij
4106 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4107 !     --- Electrostatic-interaction matrix ---
4108                 a_chuj(1,1,num_conti,i)=a22
4109                 a_chuj(1,2,num_conti,i)=a23
4110                 a_chuj(2,1,num_conti,i)=a32
4111                 a_chuj(2,2,num_conti,i)=a33
4112 !     --- Gradient of rij
4113                 do kkk=1,3
4114                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4115                 enddo
4116                 kkll=0
4117                 do k=1,2
4118                   do l=1,2
4119                     kkll=kkll+1
4120                     do m=1,3
4121                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4122                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4123                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4124                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4125                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4126                     enddo
4127                   enddo
4128                 enddo
4129                 ENDIF
4130                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4131 ! Calculate contact energies
4132                 cosa4=4.0D0*cosa
4133                 wij=cosa-3.0D0*cosb*cosg
4134                 cosbg1=cosb+cosg
4135                 cosbg2=cosb-cosg
4136 !               fac3=dsqrt(-ael6i)/r0ij**3
4137                 fac3=dsqrt(-ael6i)*r3ij
4138 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4139                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4140                 if (ees0tmp.gt.0) then
4141                   ees0pij=dsqrt(ees0tmp)
4142                 else
4143                   ees0pij=0
4144                 endif
4145                 if (shield_mode.eq.0) then
4146                 fac_shield(i)=1.0d0
4147                 fac_shield(j)=1.0d0
4148                 else
4149                 ees0plist(num_conti,i)=j
4150                 endif
4151 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4152                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4153                 if (ees0tmp.gt.0) then
4154                   ees0mij=dsqrt(ees0tmp)
4155                 else
4156                   ees0mij=0
4157                 endif
4158 !               ees0mij=0.0D0
4159                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
4160                      *sss_ele_cut &
4161                      *fac_shield(i)*fac_shield(j)
4162
4163                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
4164                      *sss_ele_cut &
4165                      *fac_shield(i)*fac_shield(j)
4166
4167 ! Diagnostics. Comment out or remove after debugging!
4168 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4169 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4170 !               ees0m(num_conti,i)=0.0D0
4171 ! End diagnostics.
4172 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4173 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4174 ! Angular derivatives of the contact function
4175                 ees0pij1=fac3/ees0pij
4176                 ees0mij1=fac3/ees0mij
4177                 fac3p=-3.0D0*fac3*rrmij
4178                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4179                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4180 !               ees0mij1=0.0D0
4181                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4182                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4183                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4184                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4185                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4186                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4187                 ecosap=ecosa1+ecosa2
4188                 ecosbp=ecosb1+ecosb2
4189                 ecosgp=ecosg1+ecosg2
4190                 ecosam=ecosa1-ecosa2
4191                 ecosbm=ecosb1-ecosb2
4192                 ecosgm=ecosg1-ecosg2
4193 ! Diagnostics
4194 !               ecosap=ecosa1
4195 !               ecosbp=ecosb1
4196 !               ecosgp=ecosg1
4197 !               ecosam=0.0D0
4198 !               ecosbm=0.0D0
4199 !               ecosgm=0.0D0
4200 ! End diagnostics
4201                 facont_hb(num_conti,i)=fcont
4202                 fprimcont=fprimcont/rij
4203 !d              facont_hb(num_conti,i)=1.0D0
4204 ! Following line is for diagnostics.
4205 !d              fprimcont=0.0D0
4206                 do k=1,3
4207                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4208                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4209                 enddo
4210                 do k=1,3
4211                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4212                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4213                 enddo
4214                 gggp(1)=gggp(1)+ees0pijp*xj &
4215                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4216                 gggp(2)=gggp(2)+ees0pijp*yj &
4217                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4218                 gggp(3)=gggp(3)+ees0pijp*zj &
4219                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4220
4221                 gggm(1)=gggm(1)+ees0mijp*xj &
4222                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
4223
4224                 gggm(2)=gggm(2)+ees0mijp*yj &
4225                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
4226
4227                 gggm(3)=gggm(3)+ees0mijp*zj &
4228                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
4229
4230 ! Derivatives due to the contact function
4231                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4232                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4233                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4234                 do k=1,3
4235 !
4236 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
4237 !          following the change of gradient-summation algorithm.
4238 !
4239 !grad                  ghalfp=0.5D0*gggp(k)
4240 !grad                  ghalfm=0.5D0*gggm(k)
4241                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
4242                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4243                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4244                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4245
4246                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
4247                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4248                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
4249                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4250
4251                   gacontp_hb3(k,num_conti,i)=gggp(k) &
4252                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4253
4254                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
4255                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
4256                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
4257                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4258
4259                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
4260                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
4261                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
4262                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4263
4264                   gacontm_hb3(k,num_conti,i)=gggm(k) &
4265                      *sss_ele_cut*fac_shield(i)*fac_shield(j)
4266
4267                 enddo
4268 ! Diagnostics. Comment out or remove after debugging!
4269 !diag           do k=1,3
4270 !diag             gacontp_hb1(k,num_conti,i)=0.0D0
4271 !diag             gacontp_hb2(k,num_conti,i)=0.0D0
4272 !diag             gacontp_hb3(k,num_conti,i)=0.0D0
4273 !diag             gacontm_hb1(k,num_conti,i)=0.0D0
4274 !diag             gacontm_hb2(k,num_conti,i)=0.0D0
4275 !diag             gacontm_hb3(k,num_conti,i)=0.0D0
4276 !diag           enddo
4277               ENDIF ! wcorr
4278               endif  ! num_conti.le.maxconts
4279             endif  ! fcont.gt.0
4280           endif    ! j.gt.i+1
4281           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4282             do k=1,4
4283               do l=1,3
4284                 ghalf=0.5d0*agg(l,k)
4285                 aggi(l,k)=aggi(l,k)+ghalf
4286                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4287                 aggj(l,k)=aggj(l,k)+ghalf
4288               enddo
4289             enddo
4290             if (j.eq.nres-1 .and. i.lt.j-2) then
4291               do k=1,4
4292                 do l=1,3
4293                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4294                 enddo
4295               enddo
4296             endif
4297           endif
4298  128  continue
4299 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
4300       return
4301       end subroutine eelecij
4302 !-----------------------------------------------------------------------------
4303       subroutine eturn3(i,eello_turn3)
4304 ! Third- and fourth-order contributions from turns
4305
4306       use comm_locel
4307 !      implicit real*8 (a-h,o-z)
4308 !      include 'DIMENSIONS'
4309 !      include 'COMMON.IOUNITS'
4310 !      include 'COMMON.GEO'
4311 !      include 'COMMON.VAR'
4312 !      include 'COMMON.LOCAL'
4313 !      include 'COMMON.CHAIN'
4314 !      include 'COMMON.DERIV'
4315 !      include 'COMMON.INTERACT'
4316 !      include 'COMMON.CONTACTS'
4317 !      include 'COMMON.TORSION'
4318 !      include 'COMMON.VECTORS'
4319 !      include 'COMMON.FFIELD'
4320 !      include 'COMMON.CONTROL'
4321       real(kind=8),dimension(3) :: ggg
4322       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4323         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4324       real(kind=8),dimension(2) :: auxvec,auxvec1
4325 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4326       real(kind=8),dimension(2,2) :: auxmat3 !el, a_temp
4327 !el      integer :: num_conti,j1,j2
4328 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4329 !el        dz_normi,xmedi,ymedi,zmedi
4330
4331 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4332 !el         dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4333 !el         num_conti,j1,j2
4334 !el local variables
4335       integer :: i,j,l,k,ilist,iresshield
4336       real(kind=8) :: eello_turn3,zj,fracinbuf,eello_t3, rlocshield
4337
4338       j=i+2
4339 !      write (iout,*) "eturn3",i,j,j1,j2
4340           zj=(c(3,j)+c(3,j+1))/2.0d0
4341           zj=mod(zj,boxzsize)
4342           if (zj.lt.0) zj=zj+boxzsize
4343           if ((zj.lt.0)) write (*,*) "CHUJ"
4344        if ((zj.gt.bordlipbot)  &
4345         .and.(zj.lt.bordliptop)) then
4346 !C the energy transfer exist
4347         if (zj.lt.buflipbot) then
4348 !C what fraction I am in
4349          fracinbuf=1.0d0-     &
4350              ((zj-bordlipbot)/lipbufthick)
4351 !C lipbufthick is thickenes of lipid buffore
4352          sslipj=sscalelip(fracinbuf)
4353          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4354         elseif (zj.gt.bufliptop) then
4355          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4356          sslipj=sscalelip(fracinbuf)
4357          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4358         else
4359          sslipj=1.0d0
4360          ssgradlipj=0.0
4361         endif
4362        else
4363          sslipj=0.0d0
4364          ssgradlipj=0.0
4365        endif
4366
4367       a_temp(1,1)=a22
4368       a_temp(1,2)=a23
4369       a_temp(2,1)=a32
4370       a_temp(2,2)=a33
4371 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4372 !
4373 !               Third-order contributions
4374 !
4375 !                 (i+2)o----(i+3)
4376 !                      | |
4377 !                      | |
4378 !                 (i+1)o----i
4379 !
4380 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4381 !d        call checkint_turn3(i,a_temp,eello_turn3_num)
4382         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4383         call transpose2(auxmat(1,1),auxmat1(1,1))
4384         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4385         if (shield_mode.eq.0) then
4386         fac_shield(i)=1.0d0
4387         fac_shield(j)=1.0d0
4388         endif
4389
4390         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2)) &
4391          *fac_shield(i)*fac_shield(j)  &
4392          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4393         eello_t3= &
4394         0.5d0*(pizda(1,1)+pizda(2,2)) &
4395         *fac_shield(i)*fac_shield(j)
4396
4397         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4398                'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
4399           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4400        (shield_mode.gt.0)) then
4401 !C          print *,i,j
4402
4403           do ilist=1,ishield_list(i)
4404            iresshield=shield_list(ilist,i)
4405            do k=1,3
4406            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4407            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+ &
4408                    rlocshield &
4409            +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4410             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4411              +rlocshield
4412            enddo
4413           enddo
4414           do ilist=1,ishield_list(j)
4415            iresshield=shield_list(ilist,j)
4416            do k=1,3
4417            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4418            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+  &
4419                    rlocshield &
4420            +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4421            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1) &
4422                   +rlocshield
4423
4424            enddo
4425           enddo
4426
4427           do k=1,3
4428             gshieldc_t3(k,i)=gshieldc_t3(k,i)+  &
4429                    grad_shield(k,i)*eello_t3/fac_shield(i)
4430             gshieldc_t3(k,j)=gshieldc_t3(k,j)+  &
4431                    grad_shield(k,j)*eello_t3/fac_shield(j)
4432             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+  &
4433                    grad_shield(k,i)*eello_t3/fac_shield(i)
4434             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+  &
4435                    grad_shield(k,j)*eello_t3/fac_shield(j)
4436            enddo
4437            endif
4438
4439 !d        write (2,*) 'i,',i,' j',j,'eello_turn3',
4440 !d     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4441 !d     &    ' eello_turn3_num',4*eello_turn3_num
4442 ! Derivatives in gamma(i)
4443         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4444         call transpose2(auxmat2(1,1),auxmat3(1,1))
4445         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4446         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))&
4447           *fac_shield(i)*fac_shield(j)        &
4448           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4449 ! Derivatives in gamma(i+1)
4450         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4451         call transpose2(auxmat2(1,1),auxmat3(1,1))
4452         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4453         gel_loc_turn3(i+1)=gel_loc_turn3(i+1) &
4454           +0.5d0*(pizda(1,1)+pizda(2,2))      &
4455           *fac_shield(i)*fac_shield(j)        &
4456           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4457
4458 ! Cartesian derivatives
4459         do l=1,3
4460 !            ghalf1=0.5d0*agg(l,1)
4461 !            ghalf2=0.5d0*agg(l,2)
4462 !            ghalf3=0.5d0*agg(l,3)
4463 !            ghalf4=0.5d0*agg(l,4)
4464           a_temp(1,1)=aggi(l,1)!+ghalf1
4465           a_temp(1,2)=aggi(l,2)!+ghalf2
4466           a_temp(2,1)=aggi(l,3)!+ghalf3
4467           a_temp(2,2)=aggi(l,4)!+ghalf4
4468           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4469           gcorr3_turn(l,i)=gcorr3_turn(l,i) &
4470             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4471           *fac_shield(i)*fac_shield(j)      &
4472           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4473
4474           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4475           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4476           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4477           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4478           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4479           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1) &
4480             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4481           *fac_shield(i)*fac_shield(j)        &
4482           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4483
4484           a_temp(1,1)=aggj(l,1)!+ghalf1
4485           a_temp(1,2)=aggj(l,2)!+ghalf2
4486           a_temp(2,1)=aggj(l,3)!+ghalf3
4487           a_temp(2,2)=aggj(l,4)!+ghalf4
4488           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4489           gcorr3_turn(l,j)=gcorr3_turn(l,j) &
4490             +0.5d0*(pizda(1,1)+pizda(2,2))  &
4491           *fac_shield(i)*fac_shield(j)      &
4492           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4493
4494           a_temp(1,1)=aggj1(l,1)
4495           a_temp(1,2)=aggj1(l,2)
4496           a_temp(2,1)=aggj1(l,3)
4497           a_temp(2,2)=aggj1(l,4)
4498           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4499           gcorr3_turn(l,j1)=gcorr3_turn(l,j1) &
4500             +0.5d0*(pizda(1,1)+pizda(2,2))    &
4501           *fac_shield(i)*fac_shield(j)        &
4502           *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4503         enddo
4504          gshieldc_t3(3,i)=gshieldc_t3(3,i)+ &
4505           ssgradlipi*eello_t3/4.0d0*lipscale
4506          gshieldc_t3(3,j)=gshieldc_t3(3,j)+ &
4507           ssgradlipj*eello_t3/4.0d0*lipscale
4508          gshieldc_t3(3,i-1)=gshieldc_t3(3,i-1)+ &
4509           ssgradlipi*eello_t3/4.0d0*lipscale
4510          gshieldc_t3(3,j-1)=gshieldc_t3(3,j-1)+ &
4511           ssgradlipj*eello_t3/4.0d0*lipscale
4512
4513       return
4514       end subroutine eturn3
4515 !-----------------------------------------------------------------------------
4516       subroutine eturn4(i,eello_turn4)
4517 ! Third- and fourth-order contributions from turns
4518
4519       use comm_locel
4520 !      implicit real*8 (a-h,o-z)
4521 !      include 'DIMENSIONS'
4522 !      include 'COMMON.IOUNITS'
4523 !      include 'COMMON.GEO'
4524 !      include 'COMMON.VAR'
4525 !      include 'COMMON.LOCAL'
4526 !      include 'COMMON.CHAIN'
4527 !      include 'COMMON.DERIV'
4528 !      include 'COMMON.INTERACT'
4529 !      include 'COMMON.CONTACTS'
4530 !      include 'COMMON.TORSION'
4531 !      include 'COMMON.VECTORS'
4532 !      include 'COMMON.FFIELD'
4533 !      include 'COMMON.CONTROL'
4534       real(kind=8),dimension(3) :: ggg
4535       real(kind=8),dimension(2,2) :: auxmat,auxmat1,auxmat2,pizda,&
4536         e1t,e2t,e3t,e1tder,e2tder,e3tder,e1a,ae3,ae3e2
4537       real(kind=8),dimension(2) :: auxvec,auxvec1
4538 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
4539       real(kind=8),dimension(2,2) :: auxmat3 !el a_temp
4540 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
4541 !el        dz_normi,xmedi,ymedi,zmedi
4542 !el      integer :: num_conti,j1,j2
4543 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
4544 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
4545 !el          num_conti,j1,j2
4546 !el local variables
4547       integer :: i,j,iti1,iti2,iti3,l,k,ilist,iresshield
4548       real(kind=8) :: eello_turn4,s1,s2,s3,zj,fracinbuf,eello_t4,&
4549          rlocshield
4550
4551       j=i+3
4552 !      if (j.ne.20) return
4553 !      print *,i,j,gshieldc_t4(2,j),gshieldc_t4(2,j+1)
4554 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4555 !
4556 !               Fourth-order contributions
4557 !
4558 !                 (i+3)o----(i+4)
4559 !                     /  |
4560 !               (i+2)o   |
4561 !                     \  |
4562 !                 (i+1)o----i
4563 !
4564 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4565 !d        call checkint_turn4(i,a_temp,eello_turn4_num)
4566 !        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
4567           zj=(c(3,j)+c(3,j+1))/2.0d0
4568           zj=mod(zj,boxzsize)
4569           if (zj.lt.0) zj=zj+boxzsize
4570        if ((zj.gt.bordlipbot)  &
4571         .and.(zj.lt.bordliptop)) then
4572 !C the energy transfer exist
4573         if (zj.lt.buflipbot) then
4574 !C what fraction I am in
4575          fracinbuf=1.0d0-     &
4576              ((zj-bordlipbot)/lipbufthick)
4577 !C lipbufthick is thickenes of lipid buffore
4578          sslipj=sscalelip(fracinbuf)
4579          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
4580         elseif (zj.gt.bufliptop) then
4581          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
4582          sslipj=sscalelip(fracinbuf)
4583          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
4584         else
4585          sslipj=1.0d0
4586          ssgradlipj=0.0
4587         endif
4588        else
4589          sslipj=0.0d0
4590          ssgradlipj=0.0
4591        endif
4592
4593         a_temp(1,1)=a22
4594         a_temp(1,2)=a23
4595         a_temp(2,1)=a32
4596         a_temp(2,2)=a33
4597         iti1=itortyp(itype(i+1,1))
4598         iti2=itortyp(itype(i+2,1))
4599         iti3=itortyp(itype(i+3,1))
4600 !        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
4601         call transpose2(EUg(1,1,i+1),e1t(1,1))
4602         call transpose2(Eug(1,1,i+2),e2t(1,1))
4603         call transpose2(Eug(1,1,i+3),e3t(1,1))
4604         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4605         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4606         s1=scalar2(b1(1,iti2),auxvec(1))
4607         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4608         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4609         s2=scalar2(b1(1,iti1),auxvec(1))
4610         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4611         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4612         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4613         if (shield_mode.eq.0) then
4614         fac_shield(i)=1.0
4615         fac_shield(j)=1.0
4616         endif
4617
4618         eello_turn4=eello_turn4-(s1+s2+s3) &
4619         *fac_shield(i)*fac_shield(j)       &
4620         *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4621         eello_t4=-(s1+s2+s3)  &
4622           *fac_shield(i)*fac_shield(j)
4623 !C Now derivative over shield:
4624           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
4625          (shield_mode.gt.0)) then
4626 !C          print *,i,j
4627
4628           do ilist=1,ishield_list(i)
4629            iresshield=shield_list(ilist,i)
4630            do k=1,3
4631            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
4632 !           print *,"rlocshield",rlocshield,grad_shield_side(k,ilist,i),iresshield
4633            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4634                    rlocshield &
4635             +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
4636             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4637            +rlocshield
4638            enddo
4639           enddo
4640           do ilist=1,ishield_list(j)
4641            iresshield=shield_list(ilist,j)
4642            do k=1,3
4643 !           print *,"rlocshieldj",j,rlocshield,grad_shield_side(k,ilist,j),iresshield
4644            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
4645            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+ &
4646                    rlocshield  &
4647            +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
4648            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1) &
4649                   +rlocshield
4650 !            print *,"after", gshieldc_t4(k,iresshield-1),iresshield-1,gshieldc_t4(k,iresshield)
4651
4652            enddo
4653           enddo
4654           do k=1,3
4655             gshieldc_t4(k,i)=gshieldc_t4(k,i)+  &
4656                    grad_shield(k,i)*eello_t4/fac_shield(i)
4657             gshieldc_t4(k,j)=gshieldc_t4(k,j)+  &
4658                    grad_shield(k,j)*eello_t4/fac_shield(j)
4659             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+  &
4660                    grad_shield(k,i)*eello_t4/fac_shield(i)
4661             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+  &
4662                    grad_shield(k,j)*eello_t4/fac_shield(j)
4663 !           print *,"gshieldc_t4(k,j+1)",j,gshieldc_t4(k,j+1)
4664            enddo
4665            endif
4666
4667         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
4668            'eturn4',i,j,-(s1+s2+s3)
4669 !d        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
4670 !d     &    ' eello_turn4_num',8*eello_turn4_num
4671 ! Derivatives in gamma(i)
4672         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
4673         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
4674         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
4675         s1=scalar2(b1(1,iti2),auxvec(1))
4676         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
4677         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4678         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3) &
4679        *fac_shield(i)*fac_shield(j)  &
4680        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4681
4682 ! Derivatives in gamma(i+1)
4683         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
4684         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
4685         s2=scalar2(b1(1,iti1),auxvec(1))
4686         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
4687         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
4688         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4689         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3) &
4690        *fac_shield(i)*fac_shield(j)  &
4691        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4692
4693 ! Derivatives in gamma(i+2)
4694         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
4695         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
4696         s1=scalar2(b1(1,iti2),auxvec(1))
4697         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
4698         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
4699         s2=scalar2(b1(1,iti1),auxvec(1))
4700         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
4701         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
4702         s3=0.5d0*(pizda(1,1)+pizda(2,2))
4703         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3) &
4704        *fac_shield(i)*fac_shield(j)  &
4705        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4706
4707 ! Cartesian derivatives
4708 ! Derivatives of this turn contributions in DC(i+2)
4709         if (j.lt.nres-1) then
4710           do l=1,3
4711             a_temp(1,1)=agg(l,1)
4712             a_temp(1,2)=agg(l,2)
4713             a_temp(2,1)=agg(l,3)
4714             a_temp(2,2)=agg(l,4)
4715             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4716             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4717             s1=scalar2(b1(1,iti2),auxvec(1))
4718             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4719             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4720             s2=scalar2(b1(1,iti1),auxvec(1))
4721             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4722             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4723             s3=0.5d0*(pizda(1,1)+pizda(2,2))
4724             ggg(l)=-(s1+s2+s3)
4725             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)&
4726        *fac_shield(i)*fac_shield(j)  &
4727        *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4728
4729           enddo
4730         endif
4731 ! Remaining derivatives of this turn contribution
4732         do l=1,3
4733           a_temp(1,1)=aggi(l,1)
4734           a_temp(1,2)=aggi(l,2)
4735           a_temp(2,1)=aggi(l,3)
4736           a_temp(2,2)=aggi(l,4)
4737           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4738           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4739           s1=scalar2(b1(1,iti2),auxvec(1))
4740           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4741           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4742           s2=scalar2(b1(1,iti1),auxvec(1))
4743           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4744           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4745           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4746           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3) &
4747          *fac_shield(i)*fac_shield(j)  &
4748          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4749
4750
4751           a_temp(1,1)=aggi1(l,1)
4752           a_temp(1,2)=aggi1(l,2)
4753           a_temp(2,1)=aggi1(l,3)
4754           a_temp(2,2)=aggi1(l,4)
4755           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4756           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4757           s1=scalar2(b1(1,iti2),auxvec(1))
4758           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4759           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4760           s2=scalar2(b1(1,iti1),auxvec(1))
4761           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4762           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4763           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4764           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3) &
4765          *fac_shield(i)*fac_shield(j)  &
4766          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4767
4768
4769           a_temp(1,1)=aggj(l,1)
4770           a_temp(1,2)=aggj(l,2)
4771           a_temp(2,1)=aggj(l,3)
4772           a_temp(2,2)=aggj(l,4)
4773           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4774           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4775           s1=scalar2(b1(1,iti2),auxvec(1))
4776           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4777           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4778           s2=scalar2(b1(1,iti1),auxvec(1))
4779           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4780           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4781           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4782 !        if (j.lt.nres-1) then
4783           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3) &
4784          *fac_shield(i)*fac_shield(j)  &
4785          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4786 !        endif
4787
4788           a_temp(1,1)=aggj1(l,1)
4789           a_temp(1,2)=aggj1(l,2)
4790           a_temp(2,1)=aggj1(l,3)
4791           a_temp(2,2)=aggj1(l,4)
4792           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
4793           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
4794           s1=scalar2(b1(1,iti2),auxvec(1))
4795           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
4796           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
4797           s2=scalar2(b1(1,iti1),auxvec(1))
4798           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
4799           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
4800           s3=0.5d0*(pizda(1,1)+pizda(2,2))
4801 !          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
4802 !        if (j.lt.nres-1) then
4803 !          print *,"juest before",j1, gcorr4_turn(l,j1)
4804           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3) &
4805          *fac_shield(i)*fac_shield(j)  &
4806          *((sslipi+sslipj)/2.0d0*lipscale+1.0d0)
4807 !            if (shield_mode.gt.0) then
4808 !             print *,"juest after",j1, gcorr4_turn(l,j1),gshieldc_t4(k,j1),gshieldc_loc_t4(k,j1),gel_loc_turn4(i+2)
4809 !            else
4810 !             print *,"juest after",j1, gcorr4_turn(l,j1),gel_loc_turn4(i+2)
4811 !            endif
4812 !         endif
4813         enddo
4814          gshieldc_t4(3,i)=gshieldc_t4(3,i)+ &
4815           ssgradlipi*eello_t4/4.0d0*lipscale
4816          gshieldc_t4(3,j)=gshieldc_t4(3,j)+ &
4817           ssgradlipj*eello_t4/4.0d0*lipscale
4818          gshieldc_t4(3,i-1)=gshieldc_t4(3,i-1)+ &
4819           ssgradlipi*eello_t4/4.0d0*lipscale
4820          gshieldc_t4(3,j-1)=gshieldc_t4(3,j-1)+ &
4821           ssgradlipj*eello_t4/4.0d0*lipscale
4822
4823       return
4824       end subroutine eturn4
4825 !-----------------------------------------------------------------------------
4826       subroutine unormderiv(u,ugrad,unorm,ungrad)
4827 ! This subroutine computes the derivatives of a normalized vector u, given
4828 ! the derivatives computed without normalization conditions, ugrad. Returns
4829 ! ungrad.
4830 !      implicit none
4831       real(kind=8),dimension(3) :: u,vec
4832       real(kind=8),dimension(3,3) ::ugrad,ungrad
4833       real(kind=8) :: unorm      !,scalar
4834       integer :: i,j
4835 !      write (2,*) 'ugrad',ugrad
4836 !      write (2,*) 'u',u
4837       do i=1,3
4838         vec(i)=scalar(ugrad(1,i),u(1))
4839       enddo
4840 !      write (2,*) 'vec',vec
4841       do i=1,3
4842         do j=1,3
4843           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
4844         enddo
4845       enddo
4846 !      write (2,*) 'ungrad',ungrad
4847       return
4848       end subroutine unormderiv
4849 !-----------------------------------------------------------------------------
4850       subroutine escp_soft_sphere(evdw2,evdw2_14)
4851 !
4852 ! This subroutine calculates the excluded-volume interaction energy between
4853 ! peptide-group centers and side chains and its gradient in virtual-bond and
4854 ! side-chain vectors.
4855 !
4856 !      implicit real*8 (a-h,o-z)
4857 !      include 'DIMENSIONS'
4858 !      include 'COMMON.GEO'
4859 !      include 'COMMON.VAR'
4860 !      include 'COMMON.LOCAL'
4861 !      include 'COMMON.CHAIN'
4862 !      include 'COMMON.DERIV'
4863 !      include 'COMMON.INTERACT'
4864 !      include 'COMMON.FFIELD'
4865 !      include 'COMMON.IOUNITS'
4866 !      include 'COMMON.CONTROL'
4867       real(kind=8),dimension(3) :: ggg
4868 !el local variables
4869       integer :: i,iint,j,k,iteli,itypj
4870       real(kind=8) :: evdw2,evdw2_14,r0_scp,xi,yi,zi,xj,yj,zj,&
4871                    fac,rij,r0ij,r0ijsq,evdwij,e1,e2
4872
4873       evdw2=0.0D0
4874       evdw2_14=0.0d0
4875       r0_scp=4.5d0
4876 !d    print '(a)','Enter ESCP'
4877 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4878       do i=iatscp_s,iatscp_e
4879         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4880         iteli=itel(i)
4881         xi=0.5D0*(c(1,i)+c(1,i+1))
4882         yi=0.5D0*(c(2,i)+c(2,i+1))
4883         zi=0.5D0*(c(3,i)+c(3,i+1))
4884
4885         do iint=1,nscp_gr(i)
4886
4887         do j=iscpstart(i,iint),iscpend(i,iint)
4888           if (itype(j,1).eq.ntyp1) cycle
4889           itypj=iabs(itype(j,1))
4890 ! Uncomment following three lines for SC-p interactions
4891 !         xj=c(1,nres+j)-xi
4892 !         yj=c(2,nres+j)-yi
4893 !         zj=c(3,nres+j)-zi
4894 ! Uncomment following three lines for Ca-p interactions
4895           xj=c(1,j)-xi
4896           yj=c(2,j)-yi
4897           zj=c(3,j)-zi
4898           rij=xj*xj+yj*yj+zj*zj
4899           r0ij=r0_scp
4900           r0ijsq=r0ij*r0ij
4901           if (rij.lt.r0ijsq) then
4902             evdwij=0.25d0*(rij-r0ijsq)**2
4903             fac=rij-r0ijsq
4904           else
4905             evdwij=0.0d0
4906             fac=0.0d0
4907           endif
4908           evdw2=evdw2+evdwij
4909 !
4910 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
4911 !
4912           ggg(1)=xj*fac
4913           ggg(2)=yj*fac
4914           ggg(3)=zj*fac
4915 !grad          if (j.lt.i) then
4916 !d          write (iout,*) 'j<i'
4917 ! Uncomment following three lines for SC-p interactions
4918 !           do k=1,3
4919 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4920 !           enddo
4921 !grad          else
4922 !d          write (iout,*) 'j>i'
4923 !grad            do k=1,3
4924 !grad              ggg(k)=-ggg(k)
4925 ! Uncomment following line for SC-p interactions
4926 !             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4927 !grad            enddo
4928 !grad          endif
4929 !grad          do k=1,3
4930 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4931 !grad          enddo
4932 !grad          kstart=min0(i+1,j)
4933 !grad          kend=max0(i-1,j-1)
4934 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4935 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
4936 !grad          do k=kstart,kend
4937 !grad            do l=1,3
4938 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4939 !grad            enddo
4940 !grad          enddo
4941           do k=1,3
4942             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4943             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4944           enddo
4945         enddo
4946
4947         enddo ! iint
4948       enddo ! i
4949       return
4950       end subroutine escp_soft_sphere
4951 !-----------------------------------------------------------------------------
4952       subroutine escp(evdw2,evdw2_14)
4953 !
4954 ! This subroutine calculates the excluded-volume interaction energy between
4955 ! peptide-group centers and side chains and its gradient in virtual-bond and
4956 ! side-chain vectors.
4957 !
4958 !      implicit real*8 (a-h,o-z)
4959 !      include 'DIMENSIONS'
4960 !      include 'COMMON.GEO'
4961 !      include 'COMMON.VAR'
4962 !      include 'COMMON.LOCAL'
4963 !      include 'COMMON.CHAIN'
4964 !      include 'COMMON.DERIV'
4965 !      include 'COMMON.INTERACT'
4966 !      include 'COMMON.FFIELD'
4967 !      include 'COMMON.IOUNITS'
4968 !      include 'COMMON.CONTROL'
4969       real(kind=8),dimension(3) :: ggg
4970 !el local variables
4971       integer :: i,iint,j,k,iteli,itypj,subchap
4972       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
4973                    e1,e2,evdwij,rij
4974       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
4975                     dist_temp, dist_init
4976       integer xshift,yshift,zshift
4977
4978       evdw2=0.0D0
4979       evdw2_14=0.0d0
4980 !d    print '(a)','Enter ESCP'
4981 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
4982       do i=iatscp_s,iatscp_e
4983         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
4984         iteli=itel(i)
4985         xi=0.5D0*(c(1,i)+c(1,i+1))
4986         yi=0.5D0*(c(2,i)+c(2,i+1))
4987         zi=0.5D0*(c(3,i)+c(3,i+1))
4988           xi=mod(xi,boxxsize)
4989           if (xi.lt.0) xi=xi+boxxsize
4990           yi=mod(yi,boxysize)
4991           if (yi.lt.0) yi=yi+boxysize
4992           zi=mod(zi,boxzsize)
4993           if (zi.lt.0) zi=zi+boxzsize
4994
4995         do iint=1,nscp_gr(i)
4996
4997         do j=iscpstart(i,iint),iscpend(i,iint)
4998           itypj=iabs(itype(j,1))
4999           if (itypj.eq.ntyp1) cycle
5000 ! Uncomment following three lines for SC-p interactions
5001 !         xj=c(1,nres+j)-xi
5002 !         yj=c(2,nres+j)-yi
5003 !         zj=c(3,nres+j)-zi
5004 ! Uncomment following three lines for Ca-p interactions
5005 !          xj=c(1,j)-xi
5006 !          yj=c(2,j)-yi
5007 !          zj=c(3,j)-zi
5008           xj=c(1,j)
5009           yj=c(2,j)
5010           zj=c(3,j)
5011           xj=mod(xj,boxxsize)
5012           if (xj.lt.0) xj=xj+boxxsize
5013           yj=mod(yj,boxysize)
5014           if (yj.lt.0) yj=yj+boxysize
5015           zj=mod(zj,boxzsize)
5016           if (zj.lt.0) zj=zj+boxzsize
5017       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5018       xj_safe=xj
5019       yj_safe=yj
5020       zj_safe=zj
5021       subchap=0
5022       do xshift=-1,1
5023       do yshift=-1,1
5024       do zshift=-1,1
5025           xj=xj_safe+xshift*boxxsize
5026           yj=yj_safe+yshift*boxysize
5027           zj=zj_safe+zshift*boxzsize
5028           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5029           if(dist_temp.lt.dist_init) then
5030             dist_init=dist_temp
5031             xj_temp=xj
5032             yj_temp=yj
5033             zj_temp=zj
5034             subchap=1
5035           endif
5036        enddo
5037        enddo
5038        enddo
5039        if (subchap.eq.1) then
5040           xj=xj_temp-xi
5041           yj=yj_temp-yi
5042           zj=zj_temp-zi
5043        else
5044           xj=xj_safe-xi
5045           yj=yj_safe-yi
5046           zj=zj_safe-zi
5047        endif
5048
5049           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5050           rij=dsqrt(1.0d0/rrij)
5051             sss_ele_cut=sscale_ele(rij)
5052             sss_ele_grad=sscagrad_ele(rij)
5053 !            print *,sss_ele_cut,sss_ele_grad,&
5054 !            (rij),r_cut_ele,rlamb_ele
5055             if (sss_ele_cut.le.0.0) cycle
5056           fac=rrij**expon2
5057           e1=fac*fac*aad(itypj,iteli)
5058           e2=fac*bad(itypj,iteli)
5059           if (iabs(j-i) .le. 2) then
5060             e1=scal14*e1
5061             e2=scal14*e2
5062             evdw2_14=evdw2_14+(e1+e2)*sss_ele_cut
5063           endif
5064           evdwij=e1+e2
5065           evdw2=evdw2+evdwij*sss_ele_cut
5066 !          if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)') &
5067 !             'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),&
5068           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
5069              'evdw2',i,j,evdwij
5070 !
5071 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
5072 !
5073           fac=-(evdwij+e1)*rrij*sss_ele_cut
5074           fac=fac+evdwij*sss_ele_grad/rij/expon
5075           ggg(1)=xj*fac
5076           ggg(2)=yj*fac
5077           ggg(3)=zj*fac
5078 !grad          if (j.lt.i) then
5079 !d          write (iout,*) 'j<i'
5080 ! Uncomment following three lines for SC-p interactions
5081 !           do k=1,3
5082 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5083 !           enddo
5084 !grad          else
5085 !d          write (iout,*) 'j>i'
5086 !grad            do k=1,3
5087 !grad              ggg(k)=-ggg(k)
5088 ! Uncomment following line for SC-p interactions
5089 !cgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5090 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5091 !grad            enddo
5092 !grad          endif
5093 !grad          do k=1,3
5094 !grad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5095 !grad          enddo
5096 !grad          kstart=min0(i+1,j)
5097 !grad          kend=max0(i-1,j-1)
5098 !d        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5099 !d        write (iout,*) ggg(1),ggg(2),ggg(3)
5100 !grad          do k=kstart,kend
5101 !grad            do l=1,3
5102 !grad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5103 !grad            enddo
5104 !grad          enddo
5105           do k=1,3
5106             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5107             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5108           enddo
5109         enddo
5110
5111         enddo ! iint
5112       enddo ! i
5113       do i=1,nct
5114         do j=1,3
5115           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5116           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5117           gradx_scp(j,i)=expon*gradx_scp(j,i)
5118         enddo
5119       enddo
5120 !******************************************************************************
5121 !
5122 !                              N O T E !!!
5123 !
5124 ! To save time the factor EXPON has been extracted from ALL components
5125 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
5126 ! use!
5127 !
5128 !******************************************************************************
5129       return
5130       end subroutine escp
5131 !-----------------------------------------------------------------------------
5132       subroutine edis(ehpb)
5133 !
5134 ! Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5135 !
5136 !      implicit real*8 (a-h,o-z)
5137 !      include 'DIMENSIONS'
5138 !      include 'COMMON.SBRIDGE'
5139 !      include 'COMMON.CHAIN'
5140 !      include 'COMMON.DERIV'
5141 !      include 'COMMON.VAR'
5142 !      include 'COMMON.INTERACT'
5143 !      include 'COMMON.IOUNITS'
5144       real(kind=8),dimension(3) :: ggg
5145 !el local variables
5146       integer :: i,j,ii,jj,iii,jjj,k
5147       real(kind=8) :: fac,eij,rdis,ehpb,dd,waga
5148
5149       ehpb=0.0D0
5150 !d      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5151 !d      write(iout,*)'link_start=',link_start,' link_end=',link_end
5152       if (link_end.eq.0) return
5153       do i=link_start,link_end
5154 ! If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5155 ! CA-CA distance used in regularization of structure.
5156         ii=ihpb(i)
5157         jj=jhpb(i)
5158 ! iii and jjj point to the residues for which the distance is assigned.
5159         if (ii.gt.nres) then
5160           iii=ii-nres
5161           jjj=jj-nres
5162         else
5163           iii=ii
5164           jjj=jj
5165         endif
5166 !        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5167 !     &    dhpb(i),dhpb1(i),forcon(i)
5168 ! 24/11/03 AL: SS bridges handled separately because of introducing a specific
5169 !    distance and angle dependent SS bond potential.
5170 !mc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5171 ! 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5172         if (.not.dyn_ss .and. i.le.nss) then
5173 ! 15/02/13 CC dynamic SSbond - additional check
5174          if (ii.gt.nres .and. iabs(itype(iii,1)).eq.1 .and. &
5175         iabs(itype(jjj,1)).eq.1) then
5176           call ssbond_ene(iii,jjj,eij)
5177           ehpb=ehpb+2*eij
5178 !d          write (iout,*) "eij",eij
5179          endif
5180         else if (ii.gt.nres .and. jj.gt.nres) then
5181 !c Restraints from contact prediction
5182           dd=dist(ii,jj)
5183           if (constr_dist.eq.11) then
5184             ehpb=ehpb+fordepth(i)**4.0d0 &
5185                *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5186             fac=fordepth(i)**4.0d0 &
5187                *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5188           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5189             ehpb,fordepth(i),dd
5190            else
5191           if (dhpb1(i).gt.0.0d0) then
5192             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5193             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5194 !c            write (iout,*) "beta nmr",
5195 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5196           else
5197             dd=dist(ii,jj)
5198             rdis=dd-dhpb(i)
5199 !C Get the force constant corresponding to this distance.
5200             waga=forcon(i)
5201 !C Calculate the contribution to energy.
5202             ehpb=ehpb+waga*rdis*rdis
5203 !c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5204 !C
5205 !C Evaluate gradient.
5206 !C
5207             fac=waga*rdis/dd
5208           endif
5209           endif
5210           do j=1,3
5211             ggg(j)=fac*(c(j,jj)-c(j,ii))
5212           enddo
5213           do j=1,3
5214             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5215             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5216           enddo
5217           do k=1,3
5218             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5219             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5220           enddo
5221         else
5222           dd=dist(ii,jj)
5223           if (constr_dist.eq.11) then
5224             ehpb=ehpb+fordepth(i)**4.0d0 &
5225                 *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5226             fac=fordepth(i)**4.0d0 &
5227                 *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5228           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj, &
5229          ehpb,fordepth(i),dd
5230            else
5231           if (dhpb1(i).gt.0.0d0) then
5232             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5233             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5234 !c            write (iout,*) "alph nmr",
5235 !c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5236           else
5237             rdis=dd-dhpb(i)
5238 !C Get the force constant corresponding to this distance.
5239             waga=forcon(i)
5240 !C Calculate the contribution to energy.
5241             ehpb=ehpb+waga*rdis*rdis
5242 !c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5243 !C
5244 !C Evaluate gradient.
5245 !C
5246             fac=waga*rdis/dd
5247           endif
5248           endif
5249
5250             do j=1,3
5251               ggg(j)=fac*(c(j,jj)-c(j,ii))
5252             enddo
5253 !cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5254 !C If this is a SC-SC distance, we need to calculate the contributions to the
5255 !C Cartesian gradient in the SC vectors (ghpbx).
5256           if (iii.lt.ii) then
5257           do j=1,3
5258             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5259             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5260           enddo
5261           endif
5262 !cgrad        do j=iii,jjj-1
5263 !cgrad          do k=1,3
5264 !cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5265 !cgrad          enddo
5266 !cgrad        enddo
5267           do k=1,3
5268             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5269             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5270           enddo
5271         endif
5272       enddo
5273       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5274
5275       return
5276       end subroutine edis
5277 !-----------------------------------------------------------------------------
5278       subroutine ssbond_ene(i,j,eij)
5279 !
5280 ! Calculate the distance and angle dependent SS-bond potential energy
5281 ! using a free-energy function derived based on RHF/6-31G** ab initio
5282 ! calculations of diethyl disulfide.
5283 !
5284 ! A. Liwo and U. Kozlowska, 11/24/03
5285 !
5286 !      implicit real*8 (a-h,o-z)
5287 !      include 'DIMENSIONS'
5288 !      include 'COMMON.SBRIDGE'
5289 !      include 'COMMON.CHAIN'
5290 !      include 'COMMON.DERIV'
5291 !      include 'COMMON.LOCAL'
5292 !      include 'COMMON.INTERACT'
5293 !      include 'COMMON.VAR'
5294 !      include 'COMMON.IOUNITS'
5295       real(kind=8),dimension(3) :: erij,dcosom1,dcosom2,gg
5296 !el local variables
5297       integer :: i,j,itypi,itypj,k
5298       real(kind=8) :: eij,rij,rrij,xi,yi,zi,dxi,dyi,dzi,dsci_inv,&
5299                    xj,yj,zj,dxj,dyj,dzj,om1,om2,om12,deltad,dscj_inv,&
5300                    deltat1,deltat2,deltat12,ed,pom1,pom2,eom1,eom2,eom12,&
5301                    cosphi,ggk
5302
5303       itypi=iabs(itype(i,1))
5304       xi=c(1,nres+i)
5305       yi=c(2,nres+i)
5306       zi=c(3,nres+i)
5307       dxi=dc_norm(1,nres+i)
5308       dyi=dc_norm(2,nres+i)
5309       dzi=dc_norm(3,nres+i)
5310 !      dsci_inv=dsc_inv(itypi)
5311       dsci_inv=vbld_inv(nres+i)
5312       itypj=iabs(itype(j,1))
5313 !      dscj_inv=dsc_inv(itypj)
5314       dscj_inv=vbld_inv(nres+j)
5315       xj=c(1,nres+j)-xi
5316       yj=c(2,nres+j)-yi
5317       zj=c(3,nres+j)-zi
5318       dxj=dc_norm(1,nres+j)
5319       dyj=dc_norm(2,nres+j)
5320       dzj=dc_norm(3,nres+j)
5321       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5322       rij=dsqrt(rrij)
5323       erij(1)=xj*rij
5324       erij(2)=yj*rij
5325       erij(3)=zj*rij
5326       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5327       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5328       om12=dxi*dxj+dyi*dyj+dzi*dzj
5329       do k=1,3
5330         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5331         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5332       enddo
5333       rij=1.0d0/rij
5334       deltad=rij-d0cm
5335       deltat1=1.0d0-om1
5336       deltat2=1.0d0+om2
5337       deltat12=om2-om1+2.0d0
5338       cosphi=om12-om1*om2
5339       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2) &
5340         +akct*deltad*deltat12 &
5341         +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5342 !      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5343 !     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5344 !     &  " deltat12",deltat12," eij",eij
5345       ed=2*akcm*deltad+akct*deltat12
5346       pom1=akct*deltad
5347       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5348       eom1=-2*akth*deltat1-pom1-om2*pom2
5349       eom2= 2*akth*deltat2+pom1-om1*pom2
5350       eom12=pom2
5351       do k=1,3
5352         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5353         ghpbx(k,i)=ghpbx(k,i)-ggk &
5354                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
5355                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5356         ghpbx(k,j)=ghpbx(k,j)+ggk &
5357                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
5358                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5359         ghpbc(k,i)=ghpbc(k,i)-ggk
5360         ghpbc(k,j)=ghpbc(k,j)+ggk
5361       enddo
5362 !
5363 ! Calculate the components of the gradient in DC and X
5364 !
5365 !grad      do k=i,j-1
5366 !grad        do l=1,3
5367 !grad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5368 !grad        enddo
5369 !grad      enddo
5370       return
5371       end subroutine ssbond_ene
5372 !-----------------------------------------------------------------------------
5373       subroutine ebond(estr)
5374 !
5375 ! Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5376 !
5377 !      implicit real*8 (a-h,o-z)
5378 !      include 'DIMENSIONS'
5379 !      include 'COMMON.LOCAL'
5380 !      include 'COMMON.GEO'
5381 !      include 'COMMON.INTERACT'
5382 !      include 'COMMON.DERIV'
5383 !      include 'COMMON.VAR'
5384 !      include 'COMMON.CHAIN'
5385 !      include 'COMMON.IOUNITS'
5386 !      include 'COMMON.NAMES'
5387 !      include 'COMMON.FFIELD'
5388 !      include 'COMMON.CONTROL'
5389 !      include 'COMMON.SETUP'
5390       real(kind=8),dimension(3) :: u,ud
5391 !el local variables
5392       integer :: i,j,iti,nbi,k
5393       real(kind=8) :: estr,estr1,diff,uprod,usum,usumsqder,&
5394                    uprod1,uprod2
5395
5396       estr=0.0d0
5397       estr1=0.0d0
5398 !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
5399 !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
5400
5401       do i=ibondp_start,ibondp_end
5402         if (itype(i-1,1).eq.ntyp1 .and. itype(i,1).eq.ntyp1) cycle
5403         if (itype(i-1,1).eq.ntyp1 .or. itype(i,1).eq.ntyp1) then
5404 !C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5405 !C          do j=1,3
5406 !C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax) &
5407 !C            *dc(j,i-1)/vbld(i)
5408 !C          enddo
5409 !C          if (energy_dec) write(iout,*) &
5410 !C             "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5411         diff = vbld(i)-vbldpDUM
5412         else
5413         diff = vbld(i)-vbldp0
5414         endif
5415         if (energy_dec) write (iout,'(a7,i5,4f7.3)') &
5416            "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5417         estr=estr+diff*diff
5418         do j=1,3
5419           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5420         enddo
5421 !        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
5422 !        endif
5423       enddo
5424       estr=0.5d0*AKP*estr+estr1
5425 !      print *,"estr_bb",estr,AKP
5426 !
5427 ! 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5428 !
5429       do i=ibond_start,ibond_end
5430         iti=iabs(itype(i,1))
5431         if (iti.eq.0) print *,"WARNING WRONG SETTTING",i
5432         if (iti.ne.10 .and. iti.ne.ntyp1) then
5433           nbi=nbondterm(iti)
5434           if (nbi.eq.1) then
5435             diff=vbld(i+nres)-vbldsc0(1,iti)
5436             if (energy_dec) write (iout,*) &
5437             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5438             AKSC(1,iti),AKSC(1,iti)*diff*diff
5439             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5440 !            print *,"estr_sc",estr
5441             do j=1,3
5442               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5443             enddo
5444           else
5445             do j=1,nbi
5446               diff=vbld(i+nres)-vbldsc0(j,iti)
5447               ud(j)=aksc(j,iti)*diff
5448               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5449             enddo
5450             uprod=u(1)
5451             do j=2,nbi
5452               uprod=uprod*u(j)
5453             enddo
5454             usum=0.0d0
5455             usumsqder=0.0d0
5456             do j=1,nbi
5457               uprod1=1.0d0
5458               uprod2=1.0d0
5459               do k=1,nbi
5460                 if (k.ne.j) then
5461                   uprod1=uprod1*u(k)
5462                   uprod2=uprod2*u(k)*u(k)
5463                 endif
5464               enddo
5465               usum=usum+uprod1
5466               usumsqder=usumsqder+ud(j)*uprod2
5467             enddo
5468             estr=estr+uprod/usum
5469 !            print *,"estr_sc",estr,i
5470
5471              if (energy_dec) write (iout,*) &
5472             "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,&
5473             AKSC(1,iti),uprod/usum
5474             do j=1,3
5475              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5476             enddo
5477           endif
5478         endif
5479       enddo
5480       return
5481       end subroutine ebond
5482 #ifdef CRYST_THETA
5483 !-----------------------------------------------------------------------------
5484       subroutine ebend(etheta)
5485 !
5486 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5487 ! angles gamma and its derivatives in consecutive thetas and gammas.
5488 !
5489       use comm_calcthet
5490 !      implicit real*8 (a-h,o-z)
5491 !      include 'DIMENSIONS'
5492 !      include 'COMMON.LOCAL'
5493 !      include 'COMMON.GEO'
5494 !      include 'COMMON.INTERACT'
5495 !      include 'COMMON.DERIV'
5496 !      include 'COMMON.VAR'
5497 !      include 'COMMON.CHAIN'
5498 !      include 'COMMON.IOUNITS'
5499 !      include 'COMMON.NAMES'
5500 !      include 'COMMON.FFIELD'
5501 !      include 'COMMON.CONTROL'
5502 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5503 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5504 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5505 !el      integer :: it
5506 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5507 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5508 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5509 !el local variables
5510       integer :: i,k,ichir1,ichir2,itype1,ichir11,ichir12,itype2,&
5511        ichir21,ichir22
5512       real(kind=8) :: etheta,delta,ss,ssd,phii,phii1,thet_pred_mean,&
5513        athetk,bthetk,dthett,dthetg1,dthetg2,f0,fprim0,E_tc0,fprim_tc0,&
5514        f1,fprim1,E_tc1,ethetai,E_theta,E_tc
5515       real(kind=8),dimension(2) :: y,z
5516
5517       delta=0.02d0*pi
5518 !      time11=dexp(-2*time)
5519 !      time12=1.0d0
5520       etheta=0.0D0
5521 !     write (*,'(a,i2)') 'EBEND ICG=',icg
5522       do i=ithet_start,ithet_end
5523         if (itype(i-1,1).eq.ntyp1) cycle
5524 ! Zero the energy function and its derivative at 0 or pi.
5525         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5526         it=itype(i-1,1)
5527         ichir1=isign(1,itype(i-2,1))
5528         ichir2=isign(1,itype(i,1))
5529          if (itype(i-2,1).eq.10) ichir1=isign(1,itype(i-1,1))
5530          if (itype(i,1).eq.10) ichir2=isign(1,itype(i-1,1))
5531          if (itype(i-1,1).eq.10) then
5532           itype1=isign(10,itype(i-2,1))
5533           ichir11=isign(1,itype(i-2,1))
5534           ichir12=isign(1,itype(i-2,1))
5535           itype2=isign(10,itype(i,1))
5536           ichir21=isign(1,itype(i,1))
5537           ichir22=isign(1,itype(i,1))
5538          endif
5539
5540         if (i.gt.3 .and. itype(i-2,1).ne.ntyp1) then
5541 #ifdef OSF
5542           phii=phi(i)
5543           if (phii.ne.phii) phii=150.0
5544 #else
5545           phii=phi(i)
5546 #endif
5547           y(1)=dcos(phii)
5548           y(2)=dsin(phii)
5549         else
5550           y(1)=0.0D0
5551           y(2)=0.0D0
5552         endif
5553         if (i.lt.nres .and. itype(i,1).ne.ntyp1) then
5554 #ifdef OSF
5555           phii1=phi(i+1)
5556           if (phii1.ne.phii1) phii1=150.0
5557           phii1=pinorm(phii1)
5558           z(1)=cos(phii1)
5559 #else
5560           phii1=phi(i+1)
5561           z(1)=dcos(phii1)
5562 #endif
5563           z(2)=dsin(phii1)
5564         else
5565           z(1)=0.0D0
5566           z(2)=0.0D0
5567         endif
5568 ! Calculate the "mean" value of theta from the part of the distribution
5569 ! dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5570 ! In following comments this theta will be referred to as t_c.
5571         thet_pred_mean=0.0d0
5572         do k=1,2
5573             athetk=athet(k,it,ichir1,ichir2)
5574             bthetk=bthet(k,it,ichir1,ichir2)
5575           if (it.eq.10) then
5576              athetk=athet(k,itype1,ichir11,ichir12)
5577              bthetk=bthet(k,itype2,ichir21,ichir22)
5578           endif
5579          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5580         enddo
5581         dthett=thet_pred_mean*ssd
5582         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5583 ! Derivatives of the "mean" values in gamma1 and gamma2.
5584         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2) &
5585                +athet(2,it,ichir1,ichir2)*y(1))*ss
5586         dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2) &
5587                +bthet(2,it,ichir1,ichir2)*z(1))*ss
5588          if (it.eq.10) then
5589         dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2) &
5590              +athet(2,itype1,ichir11,ichir12)*y(1))*ss
5591         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2) &
5592                +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5593          endif
5594         if (theta(i).gt.pi-delta) then
5595           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,&
5596                E_tc0)
5597           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5598           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5599           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,&
5600               E_theta)
5601           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,&
5602               E_tc)
5603         else if (theta(i).lt.delta) then
5604           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5605           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5606           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,&
5607               E_theta)
5608           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
5609           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,&
5610               E_tc)
5611         else
5612           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,&
5613               E_theta,E_tc)
5614         endif
5615         etheta=etheta+ethetai
5616         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5617             'ebend',i,ethetai
5618         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
5619         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
5620         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
5621       enddo
5622 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5623
5624 ! Ufff.... We've done all this!!!
5625       return
5626       end subroutine ebend
5627 !-----------------------------------------------------------------------------
5628       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc)
5629
5630       use comm_calcthet
5631 !      implicit real*8 (a-h,o-z)
5632 !      include 'DIMENSIONS'
5633 !      include 'COMMON.LOCAL'
5634 !      include 'COMMON.IOUNITS'
5635 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
5636 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5637 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec
5638       integer :: i,j,k
5639       real(kind=8) :: thetai,thet_pred_mean,theta0i,ethetai,E_theta,E_tc
5640 !el      integer :: it
5641 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
5642 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
5643 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5644 !el local variables
5645       real(kind=8) :: sig,fac,escloci0,escloci1,esclocbi0,dersc12,&
5646        esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5647
5648 ! Calculate the contributions to both Gaussian lobes.
5649 ! 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
5650 ! The "polynomial part" of the "standard deviation" of this part of
5651 ! the distribution.
5652         sig=polthet(3,it)
5653         do j=2,0,-1
5654           sig=sig*thet_pred_mean+polthet(j,it)
5655         enddo
5656 ! Derivative of the "interior part" of the "standard deviation of the"
5657 ! gamma-dependent Gaussian lobe in t_c.
5658         sigtc=3*polthet(3,it)
5659         do j=2,1,-1
5660           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
5661         enddo
5662         sigtc=sig*sigtc
5663 ! Set the parameters of both Gaussian lobes of the distribution.
5664 ! "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
5665         fac=sig*sig+sigc0(it)
5666         sigcsq=fac+fac
5667         sigc=1.0D0/sigcsq
5668 ! Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
5669         sigsqtc=-4.0D0*sigcsq*sigtc
5670 !       print *,i,sig,sigtc,sigsqtc
5671 ! Following variable (sigtc) is d[sigma(t_c)]/dt_c
5672         sigtc=-sigtc/(fac*fac)
5673 ! Following variable is sigma(t_c)**(-2)
5674         sigcsq=sigcsq*sigcsq
5675         sig0i=sig0(it)
5676         sig0inv=1.0D0/sig0i**2
5677         delthec=thetai-thet_pred_mean
5678         delthe0=thetai-theta0i
5679         term1=-0.5D0*sigcsq*delthec*delthec
5680         term2=-0.5D0*sig0inv*delthe0*delthe0
5681 ! Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
5682 ! NaNs in taking the logarithm. We extract the largest exponent which is added
5683 ! to the energy (this being the log of the distribution) at the end of energy
5684 ! term evaluation for this virtual-bond angle.
5685         if (term1.gt.term2) then
5686           termm=term1
5687           term2=dexp(term2-termm)
5688           term1=1.0d0
5689         else
5690           termm=term2
5691           term1=dexp(term1-termm)
5692           term2=1.0d0
5693         endif
5694 ! The ratio between the gamma-independent and gamma-dependent lobes of
5695 ! the distribution is a Gaussian function of thet_pred_mean too.
5696         diffak=gthet(2,it)-thet_pred_mean
5697         ratak=diffak/gthet(3,it)**2
5698         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
5699 ! Let's differentiate it in thet_pred_mean NOW.
5700         aktc=ak*ratak
5701 ! Now put together the distribution terms to make complete distribution.
5702         termexp=term1+ak*term2
5703         termpre=sigc+ak*sig0i
5704 ! Contribution of the bending energy from this theta is just the -log of
5705 ! the sum of the contributions from the two lobes and the pre-exponential
5706 ! factor. Simple enough, isn't it?
5707         ethetai=(-dlog(termexp)-termm+dlog(termpre))
5708 ! NOW the derivatives!!!
5709 ! 6/6/97 Take into account the deformation.
5710         E_theta=(delthec*sigcsq*term1 &
5711              +ak*delthe0*sig0inv*term2)/termexp
5712         E_tc=((sigtc+aktc*sig0i)/termpre &
5713             -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+ &
5714              aktc*term2)/termexp)
5715       return
5716       end subroutine theteng
5717 #else
5718 !-----------------------------------------------------------------------------
5719       subroutine ebend(etheta,ethetacnstr)
5720 !
5721 ! Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5722 ! angles gamma and its derivatives in consecutive thetas and gammas.
5723 ! ab initio-derived potentials from
5724 ! Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
5725 !
5726 !      implicit real*8 (a-h,o-z)
5727 !      include 'DIMENSIONS'
5728 !      include 'COMMON.LOCAL'
5729 !      include 'COMMON.GEO'
5730 !      include 'COMMON.INTERACT'
5731 !      include 'COMMON.DERIV'
5732 !      include 'COMMON.VAR'
5733 !      include 'COMMON.CHAIN'
5734 !      include 'COMMON.IOUNITS'
5735 !      include 'COMMON.NAMES'
5736 !      include 'COMMON.FFIELD'
5737 !      include 'COMMON.CONTROL'
5738       real(kind=8),dimension(nntheterm) :: coskt,sinkt !mmaxtheterm
5739       real(kind=8),dimension(nsingle) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
5740       real(kind=8),dimension(ndouble,ndouble) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
5741       logical :: lprn=.false., lprn1=.false.
5742 !el local variables
5743       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
5744       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
5745       real(kind=8) :: aux,etheta,ccl,ssl,scl,csl,ethetacnstr
5746 ! local variables for constrains
5747       real(kind=8) :: difi,thetiii
5748        integer itheta
5749
5750       etheta=0.0D0
5751       do i=ithet_start,ithet_end
5752         if (itype(i-1,1).eq.ntyp1) cycle
5753         if (itype(i-2,1).eq.ntyp1.or.itype(i,1).eq.ntyp1) cycle
5754         if (iabs(itype(i+1,1)).eq.20) iblock=2
5755         if (iabs(itype(i+1,1)).ne.20) iblock=1
5756         dethetai=0.0d0
5757         dephii=0.0d0
5758         dephii1=0.0d0
5759         theti2=0.5d0*theta(i)
5760         ityp2=ithetyp((itype(i-1,1)))
5761         do k=1,nntheterm
5762           coskt(k)=dcos(k*theti2)
5763           sinkt(k)=dsin(k*theti2)
5764         enddo
5765         if (i.gt.3 .and. itype(max0(i-3,1),1).ne.ntyp1) then
5766 #ifdef OSF
5767           phii=phi(i)
5768           if (phii.ne.phii) phii=150.0
5769 #else
5770           phii=phi(i)
5771 #endif
5772           ityp1=ithetyp((itype(i-2,1)))
5773 ! propagation of chirality for glycine type
5774           do k=1,nsingle
5775             cosph1(k)=dcos(k*phii)
5776             sinph1(k)=dsin(k*phii)
5777           enddo
5778         else
5779           phii=0.0d0
5780           ityp1=ithetyp(itype(i-2,1))
5781           do k=1,nsingle
5782             cosph1(k)=0.0d0
5783             sinph1(k)=0.0d0
5784           enddo
5785         endif
5786         if (i.lt.nres .and. itype(i+1,1).ne.ntyp1) then
5787 #ifdef OSF
5788           phii1=phi(i+1)
5789           if (phii1.ne.phii1) phii1=150.0
5790           phii1=pinorm(phii1)
5791 #else
5792           phii1=phi(i+1)
5793 #endif
5794           ityp3=ithetyp((itype(i,1)))
5795           do k=1,nsingle
5796             cosph2(k)=dcos(k*phii1)
5797             sinph2(k)=dsin(k*phii1)
5798           enddo
5799         else
5800           phii1=0.0d0
5801           ityp3=ithetyp(itype(i,1))
5802           do k=1,nsingle
5803             cosph2(k)=0.0d0
5804             sinph2(k)=0.0d0
5805           enddo
5806         endif
5807         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5808         do k=1,ndouble
5809           do l=1,k-1
5810             ccl=cosph1(l)*cosph2(k-l)
5811             ssl=sinph1(l)*sinph2(k-l)
5812             scl=sinph1(l)*cosph2(k-l)
5813             csl=cosph1(l)*sinph2(k-l)
5814             cosph1ph2(l,k)=ccl-ssl
5815             cosph1ph2(k,l)=ccl+ssl
5816             sinph1ph2(l,k)=scl+csl
5817             sinph1ph2(k,l)=scl-csl
5818           enddo
5819         enddo
5820         if (lprn) then
5821         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
5822           " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5823         write (iout,*) "coskt and sinkt"
5824         do k=1,nntheterm
5825           write (iout,*) k,coskt(k),sinkt(k)
5826         enddo
5827         endif
5828         do k=1,ntheterm
5829           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5830           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock) &
5831             *coskt(k)
5832           if (lprn) &
5833           write (iout,*) "k",k,&
5834            "aathet",aathet(k,ityp1,ityp2,ityp3,iblock),&
5835            " ethetai",ethetai
5836         enddo
5837         if (lprn) then
5838         write (iout,*) "cosph and sinph"
5839         do k=1,nsingle
5840           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5841         enddo
5842         write (iout,*) "cosph1ph2 and sinph2ph2"
5843         do k=2,ndouble
5844           do l=1,k-1
5845             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
5846                sinph1ph2(l,k),sinph1ph2(k,l)
5847           enddo
5848         enddo
5849         write(iout,*) "ethetai",ethetai
5850         endif
5851         do m=1,ntheterm2
5852           do k=1,nsingle
5853             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k) &
5854                +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k) &
5855                +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k) &
5856                +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5857             ethetai=ethetai+sinkt(m)*aux
5858             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5859             dephii=dephii+k*sinkt(m)* &
5860                 (ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)- &
5861                 bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5862             dephii1=dephii1+k*sinkt(m)* &
5863                 (eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)- &
5864                 ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5865             if (lprn) &
5866             write (iout,*) "m",m," k",k," bbthet", &
5867                bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet", &
5868                ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet", &
5869                ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet", &
5870                eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5871           enddo
5872         enddo
5873         if (lprn) &
5874         write(iout,*) "ethetai",ethetai
5875         do m=1,ntheterm3
5876           do k=2,ndouble
5877             do l=1,k-1
5878               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5879                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+ &
5880                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5881                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5882               ethetai=ethetai+sinkt(m)*aux
5883               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5884               dephii=dephii+l*sinkt(m)* &
5885                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)- &
5886                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5887                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+ &
5888                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5889               dephii1=dephii1+(k-l)*sinkt(m)* &
5890                   (-ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+ &
5891                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+ &
5892                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)- &
5893                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5894               if (lprn) then
5895               write (iout,*) "m",m," k",k," l",l," ffthet",&
5896                   ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5897                   ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",&
5898                   ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),&
5899                   ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),&
5900                   " ethetai",ethetai
5901               write (iout,*) cosph1ph2(l,k)*sinkt(m),&
5902                   cosph1ph2(k,l)*sinkt(m),&
5903                   sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5904               endif
5905             enddo
5906           enddo
5907         enddo
5908 10      continue
5909 !        lprn1=.true.
5910         if (lprn1) &
5911           write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
5912          i,theta(i)*rad2deg,phii*rad2deg,&
5913          phii1*rad2deg,ethetai
5914 !        lprn1=.false.
5915         etheta=etheta+ethetai
5916         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
5917                                     'ebend',i,ethetai
5918         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5919         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5920         gloc(nphi+i-2,icg)=wang*dethetai
5921       enddo
5922 !-----------thete constrains
5923 !      if (tor_mode.ne.2) then
5924       ethetacnstr=0.0d0
5925 !      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5926       do i=ithetaconstr_start,ithetaconstr_end
5927         itheta=itheta_constr(i)
5928         thetiii=theta(itheta)
5929         difi=pinorm(thetiii-theta_constr0(i))
5930         if (difi.gt.theta_drange(i)) then
5931           difi=difi-theta_drange(i)
5932           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5933           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5934          +for_thet_constr(i)*difi**3
5935         else if (difi.lt.-drange(i)) then
5936           difi=difi+drange(i)
5937           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5938           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg) &
5939          +for_thet_constr(i)*difi**3
5940         else
5941           difi=0.0
5942         endif
5943        if (energy_dec) then
5944         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc", &
5945          i,itheta,rad2deg*thetiii, &
5946          rad2deg*theta_constr0(i),  rad2deg*theta_drange(i), &
5947          rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4, &
5948          gloc(itheta+nphi-2,icg)
5949         endif
5950       enddo
5951 !      endif
5952
5953       return
5954       end subroutine ebend
5955 #endif
5956 #ifdef CRYST_SC
5957 !-----------------------------------------------------------------------------
5958       subroutine esc(escloc)
5959 ! Calculate the local energy of a side chain and its derivatives in the
5960 ! corresponding virtual-bond valence angles THETA and the spherical angles
5961 ! ALPHA and OMEGA.
5962 !
5963       use comm_sccalc
5964 !      implicit real*8 (a-h,o-z)
5965 !      include 'DIMENSIONS'
5966 !      include 'COMMON.GEO'
5967 !      include 'COMMON.LOCAL'
5968 !      include 'COMMON.VAR'
5969 !      include 'COMMON.INTERACT'
5970 !      include 'COMMON.DERIV'
5971 !      include 'COMMON.CHAIN'
5972 !      include 'COMMON.IOUNITS'
5973 !      include 'COMMON.NAMES'
5974 !      include 'COMMON.FFIELD'
5975 !      include 'COMMON.CONTROL'
5976       real(kind=8),dimension(3) :: x,dersc,xemp,dersc0,dersc1,&
5977          ddersc0,ddummy,xtemp,temp
5978 !el      real(kind=8) :: time11,time12,time112,theti
5979       real(kind=8) :: escloc,delta
5980 !el      integer :: it,nlobit
5981 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
5982 !el local variables
5983       integer :: i,k
5984       real(kind=8) :: escloci0,escloci1,escloci,esclocbi0,&
5985        dersc12,esclocbi1,chuju,esclocbi,dersc02,dersc01,ss,ssd
5986       delta=0.02d0*pi
5987       escloc=0.0D0
5988 !     write (iout,'(a)') 'ESC'
5989       do i=loc_start,loc_end
5990         it=itype(i,1)
5991         if (it.eq.ntyp1) cycle
5992         if (it.eq.10) goto 1
5993         nlobit=nlob(iabs(it))
5994 !       print *,'i=',i,' it=',it,' nlobit=',nlobit
5995 !       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5996         theti=theta(i+1)-pipol
5997         x(1)=dtan(theti)
5998         x(2)=alph(i)
5999         x(3)=omeg(i)
6000
6001         if (x(2).gt.pi-delta) then
6002           xtemp(1)=x(1)
6003           xtemp(2)=pi-delta
6004           xtemp(3)=x(3)
6005           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6006           xtemp(2)=pi
6007           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6008           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),&
6009               escloci,dersc(2))
6010           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6011               ddersc0(1),dersc(1))
6012           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),&
6013               ddersc0(3),dersc(3))
6014           xtemp(2)=pi-delta
6015           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6016           xtemp(2)=pi
6017           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6018           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,&
6019                   dersc0(2),esclocbi,dersc02)
6020           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),&
6021                   dersc12,dersc01)
6022           call splinthet(x(2),0.5d0*delta,ss,ssd)
6023           dersc0(1)=dersc01
6024           dersc0(2)=dersc02
6025           dersc0(3)=0.0d0
6026           do k=1,3
6027             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6028           enddo
6029           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6030 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6031 !    &             esclocbi,ss,ssd
6032           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6033 !         escloci=esclocbi
6034 !         write (iout,*) escloci
6035         else if (x(2).lt.delta) then
6036           xtemp(1)=x(1)
6037           xtemp(2)=delta
6038           xtemp(3)=x(3)
6039           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6040           xtemp(2)=0.0d0
6041           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6042           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),&
6043               escloci,dersc(2))
6044           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6045               ddersc0(1),dersc(1))
6046           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),&
6047               ddersc0(3),dersc(3))
6048           xtemp(2)=delta
6049           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6050           xtemp(2)=0.0d0
6051           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6052           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,&
6053                   dersc0(2),esclocbi,dersc02)
6054           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),&
6055                   dersc12,dersc01)
6056           dersc0(1)=dersc01
6057           dersc0(2)=dersc02
6058           dersc0(3)=0.0d0
6059           call splinthet(x(2),0.5d0*delta,ss,ssd)
6060           do k=1,3
6061             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6062           enddo
6063           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6064 !         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6065 !    &             esclocbi,ss,ssd
6066           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6067 !         write (iout,*) escloci
6068         else
6069           call enesc(x,escloci,dersc,ddummy,.false.)
6070         endif
6071
6072         escloc=escloc+escloci
6073         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6074            'escloc',i,escloci
6075 !       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6076
6077         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+ &
6078          wscloc*dersc(1)
6079         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6080         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6081     1   continue
6082       enddo
6083       return
6084       end subroutine esc
6085 !-----------------------------------------------------------------------------
6086       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6087
6088       use comm_sccalc
6089 !      implicit real*8 (a-h,o-z)
6090 !      include 'DIMENSIONS'
6091 !      include 'COMMON.GEO'
6092 !      include 'COMMON.LOCAL'
6093 !      include 'COMMON.IOUNITS'
6094 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6095       real(kind=8),dimension(3) :: x,z,dersc,ddersc
6096       real(kind=8),dimension(3,nlobit,-1:1) :: Ax !(3,maxlob,-1:1)
6097       real(kind=8),dimension(nlobit,-1:1) :: contr !(maxlob,-1:1)
6098       real(kind=8) :: escloci
6099       logical :: mixed
6100 !el local variables
6101       integer :: j,iii,l,k !el,it,nlobit
6102       real(kind=8) :: escloc_i,x3,Axk,expfac,emin !el,theti,&
6103 !el       time11,time12,time112
6104 !       write (iout,*) 'it=',it,' nlobit=',nlobit
6105         escloc_i=0.0D0
6106         do j=1,3
6107           dersc(j)=0.0D0
6108           if (mixed) ddersc(j)=0.0d0
6109         enddo
6110         x3=x(3)
6111
6112 ! Because of periodicity of the dependence of the SC energy in omega we have
6113 ! to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6114 ! To avoid underflows, first compute & store the exponents.
6115
6116         do iii=-1,1
6117
6118           x(3)=x3+iii*dwapi
6119
6120           do j=1,nlobit
6121             do k=1,3
6122               z(k)=x(k)-censc(k,j,it)
6123             enddo
6124             do k=1,3
6125               Axk=0.0D0
6126               do l=1,3
6127                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6128               enddo
6129               Ax(k,j,iii)=Axk
6130             enddo
6131             expfac=0.0D0
6132             do k=1,3
6133               expfac=expfac+Ax(k,j,iii)*z(k)
6134             enddo
6135             contr(j,iii)=expfac
6136           enddo ! j
6137
6138         enddo ! iii
6139
6140         x(3)=x3
6141 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6142 ! subsequent NaNs and INFs in energy calculation.
6143 ! Find the largest exponent
6144         emin=contr(1,-1)
6145         do iii=-1,1
6146           do j=1,nlobit
6147             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6148           enddo
6149         enddo
6150         emin=0.5D0*emin
6151 !d      print *,'it=',it,' emin=',emin
6152
6153 ! Compute the contribution to SC energy and derivatives
6154         do iii=-1,1
6155
6156           do j=1,nlobit
6157 #ifdef OSF
6158             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6159             if(adexp.ne.adexp) adexp=1.0
6160             expfac=dexp(adexp)
6161 #else
6162             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6163 #endif
6164 !d          print *,'j=',j,' expfac=',expfac
6165             escloc_i=escloc_i+expfac
6166             do k=1,3
6167               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6168             enddo
6169             if (mixed) then
6170               do k=1,3,2
6171                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii) &
6172                   +gaussc(k,2,j,it))*expfac
6173               enddo
6174             endif
6175           enddo
6176
6177         enddo ! iii
6178
6179         dersc(1)=dersc(1)/cos(theti)**2
6180         ddersc(1)=ddersc(1)/cos(theti)**2
6181         ddersc(3)=ddersc(3)
6182
6183         escloci=-(dlog(escloc_i)-emin)
6184         do j=1,3
6185           dersc(j)=dersc(j)/escloc_i
6186         enddo
6187         if (mixed) then
6188           do j=1,3,2
6189             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6190           enddo
6191         endif
6192       return
6193       end subroutine enesc
6194 !-----------------------------------------------------------------------------
6195       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6196
6197       use comm_sccalc
6198 !      implicit real*8 (a-h,o-z)
6199 !      include 'DIMENSIONS'
6200 !      include 'COMMON.GEO'
6201 !      include 'COMMON.LOCAL'
6202 !      include 'COMMON.IOUNITS'
6203 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6204       real(kind=8),dimension(3) :: x,z,dersc
6205       real(kind=8),dimension(3,nlobit) :: Ax !(3,maxlob)
6206       real(kind=8),dimension(nlobit) :: contr !(maxlob)
6207       real(kind=8) :: escloci,dersc12,emin
6208       logical :: mixed
6209 !el local varables
6210       integer :: j,k,l !el,it,nlobit
6211       real(kind=8) :: escloc_i,Axk,expfac !el,time11,time12,time112,theti
6212
6213       escloc_i=0.0D0
6214
6215       do j=1,3
6216         dersc(j)=0.0D0
6217       enddo
6218
6219       do j=1,nlobit
6220         do k=1,2
6221           z(k)=x(k)-censc(k,j,it)
6222         enddo
6223         z(3)=dwapi
6224         do k=1,3
6225           Axk=0.0D0
6226           do l=1,3
6227             Axk=Axk+gaussc(l,k,j,it)*z(l)
6228           enddo
6229           Ax(k,j)=Axk
6230         enddo
6231         expfac=0.0D0
6232         do k=1,3
6233           expfac=expfac+Ax(k,j)*z(k)
6234         enddo
6235         contr(j)=expfac
6236       enddo ! j
6237
6238 ! As in the case of ebend, we want to avoid underflows in exponentiation and
6239 ! subsequent NaNs and INFs in energy calculation.
6240 ! Find the largest exponent
6241       emin=contr(1)
6242       do j=1,nlobit
6243         if (emin.gt.contr(j)) emin=contr(j)
6244       enddo
6245       emin=0.5D0*emin
6246
6247 ! Compute the contribution to SC energy and derivatives
6248
6249       dersc12=0.0d0
6250       do j=1,nlobit
6251         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6252         escloc_i=escloc_i+expfac
6253         do k=1,2
6254           dersc(k)=dersc(k)+Ax(k,j)*expfac
6255         enddo
6256         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j) &
6257                   +gaussc(1,2,j,it))*expfac
6258         dersc(3)=0.0d0
6259       enddo
6260
6261       dersc(1)=dersc(1)/cos(theti)**2
6262       dersc12=dersc12/cos(theti)**2
6263       escloci=-(dlog(escloc_i)-emin)
6264       do j=1,2
6265         dersc(j)=dersc(j)/escloc_i
6266       enddo
6267       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6268       return
6269       end subroutine enesc_bound
6270 #else
6271 !-----------------------------------------------------------------------------
6272       subroutine esc(escloc)
6273 ! Calculate the local energy of a side chain and its derivatives in the
6274 ! corresponding virtual-bond valence angles THETA and the spherical angles
6275 ! ALPHA and OMEGA derived from AM1 all-atom calculations.
6276 ! added by Urszula Kozlowska. 07/11/2007
6277 !
6278       use comm_sccalc
6279 !      implicit real*8 (a-h,o-z)
6280 !      include 'DIMENSIONS'
6281 !      include 'COMMON.GEO'
6282 !      include 'COMMON.LOCAL'
6283 !      include 'COMMON.VAR'
6284 !      include 'COMMON.SCROT'
6285 !      include 'COMMON.INTERACT'
6286 !      include 'COMMON.DERIV'
6287 !      include 'COMMON.CHAIN'
6288 !      include 'COMMON.IOUNITS'
6289 !      include 'COMMON.NAMES'
6290 !      include 'COMMON.FFIELD'
6291 !      include 'COMMON.CONTROL'
6292 !      include 'COMMON.VECTORS'
6293       real(kind=8),dimension(3) :: x_prime,y_prime,z_prime
6294       real(kind=8),dimension(65) :: x
6295       real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1,sumene2,sumene3,&
6296          sumene4,s1,s1_6,s2,s2_6,de_dxx,de_dyy,de_dzz,de_dt
6297       real(kind=8) :: s1_t,s1_6_t,s2_t,s2_6_t
6298       real(kind=8),dimension(3) :: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,dYY_Ci,&
6299          dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
6300 !el local variables
6301       integer :: i,j,k !el,it,nlobit
6302       real(kind=8) :: cosfac2,sinfac2,cosfac,sinfac,escloc,delta
6303 !el      real(kind=8) :: time11,time12,time112,theti
6304 !el      common /sccalc/ time11,time12,time112,theti,it,nlobit
6305       real(kind=8) :: dscp1,dscp2,pom_s1,pom_s16,pom_s2,pom_s26,&
6306                    pom,pom_dx,pom_dy,pom_dt1,pom_dt2,pom1,pom2,&
6307                    sumene1x,sumene2x,sumene3x,sumene4x,&
6308                    sumene1y,sumene2y,sumene3y,sumene4y,cossc,cossc1,&
6309                    cosfac2xx,sinfac2yy
6310 #ifdef DEBUG
6311       real(kind=8) :: aincr,xxsave,sumenep,de_dxx_num,yysave,&
6312                    de_dyy_num,zzsave,de_dzz_num,costsave,sintsave,&
6313                    de_dt_num
6314 #endif
6315 !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
6316
6317       delta=0.02d0*pi
6318       escloc=0.0D0
6319       do i=loc_start,loc_end
6320         if (itype(i,1).eq.ntyp1) cycle
6321         costtab(i+1) =dcos(theta(i+1))
6322         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6323         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6324         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6325         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6326         cosfac=dsqrt(cosfac2)
6327         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6328         sinfac=dsqrt(sinfac2)
6329         it=iabs(itype(i,1))
6330         if (it.eq.10) goto 1
6331 !
6332 !  Compute the axes of tghe local cartesian coordinates system; store in
6333 !   x_prime, y_prime and z_prime
6334 !
6335         do j=1,3
6336           x_prime(j) = 0.00
6337           y_prime(j) = 0.00
6338           z_prime(j) = 0.00
6339         enddo
6340 !        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6341 !     &   dc_norm(3,i+nres)
6342         do j = 1,3
6343           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6344           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6345         enddo
6346         do j = 1,3
6347           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i,1)))
6348         enddo
6349 !       write (2,*) "i",i
6350 !       write (2,*) "x_prime",(x_prime(j),j=1,3)
6351 !       write (2,*) "y_prime",(y_prime(j),j=1,3)
6352 !       write (2,*) "z_prime",(z_prime(j),j=1,3)
6353 !       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6354 !      & " xy",scalar(x_prime(1),y_prime(1)),
6355 !      & " xz",scalar(x_prime(1),z_prime(1)),
6356 !      & " yy",scalar(y_prime(1),y_prime(1)),
6357 !      & " yz",scalar(y_prime(1),z_prime(1)),
6358 !      & " zz",scalar(z_prime(1),z_prime(1))
6359 !
6360 ! Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6361 ! to local coordinate system. Store in xx, yy, zz.
6362 !
6363         xx=0.0d0
6364         yy=0.0d0
6365         zz=0.0d0
6366         do j = 1,3
6367           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6368           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6369           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6370         enddo
6371
6372         xxtab(i)=xx
6373         yytab(i)=yy
6374         zztab(i)=zz
6375 !
6376 ! Compute the energy of the ith side cbain
6377 !
6378 !        write (2,*) "xx",xx," yy",yy," zz",zz
6379         it=iabs(itype(i,1))
6380         do j = 1,65
6381           x(j) = sc_parmin(j,it)
6382         enddo
6383 #ifdef CHECK_COORD
6384 !c diagnostics - remove later
6385         xx1 = dcos(alph(2))
6386         yy1 = dsin(alph(2))*dcos(omeg(2))
6387         zz1 = -dsign(1.0,dfloat(itype(i,1)))*dsin(alph(2))*dsin(omeg(2))
6388         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
6389           alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
6390           xx1,yy1,zz1
6391 !,"  --- ", xx_w,yy_w,zz_w
6392 ! end diagnostics
6393 #endif
6394         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6395          + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6396          + x(10)*yy*zz
6397         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6398          + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6399          + x(20)*yy*zz
6400         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6401          +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6402          +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6403          +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6404          +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6405          +x(40)*xx*yy*zz
6406         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6407          +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6408          +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6409          +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6410          +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6411          +x(60)*xx*yy*zz
6412         dsc_i   = 0.743d0+x(61)
6413         dp2_i   = 1.9d0+x(62)
6414         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6415                *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6416         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6417                *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6418         s1=(1+x(63))/(0.1d0 + dscp1)
6419         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6420         s2=(1+x(65))/(0.1d0 + dscp2)
6421         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6422         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6) &
6423       + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6424 !        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6425 !     &   sumene4,
6426 !     &   dscp1,dscp2,sumene
6427 !        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6428         escloc = escloc + sumene
6429 !        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i,1)
6430 !     & ,zz,xx,yy
6431 !#define DEBUG
6432 #ifdef DEBUG
6433 !
6434 ! This section to check the numerical derivatives of the energy of ith side
6435 ! chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6436 ! #define DEBUG in the code to turn it on.
6437 !
6438         write (2,*) "sumene               =",sumene
6439         aincr=1.0d-7
6440         xxsave=xx
6441         xx=xx+aincr
6442         write (2,*) xx,yy,zz
6443         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6444         de_dxx_num=(sumenep-sumene)/aincr
6445         xx=xxsave
6446         write (2,*) "xx+ sumene from enesc=",sumenep
6447         yysave=yy
6448         yy=yy+aincr
6449         write (2,*) xx,yy,zz
6450         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6451         de_dyy_num=(sumenep-sumene)/aincr
6452         yy=yysave
6453         write (2,*) "yy+ sumene from enesc=",sumenep
6454         zzsave=zz
6455         zz=zz+aincr
6456         write (2,*) xx,yy,zz
6457         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6458         de_dzz_num=(sumenep-sumene)/aincr
6459         zz=zzsave
6460         write (2,*) "zz+ sumene from enesc=",sumenep
6461         costsave=cost2tab(i+1)
6462         sintsave=sint2tab(i+1)
6463         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6464         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6465         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6466         de_dt_num=(sumenep-sumene)/aincr
6467         write (2,*) " t+ sumene from enesc=",sumenep
6468         cost2tab(i+1)=costsave
6469         sint2tab(i+1)=sintsave
6470 ! End of diagnostics section.
6471 #endif
6472 !
6473 ! Compute the gradient of esc
6474 !
6475 !        zz=zz*dsign(1.0,dfloat(itype(i,1)))
6476         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6477         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6478         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6479         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6480         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6481         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6482         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6483         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6484         pom1=(sumene3*sint2tab(i+1)+sumene1) &
6485            *(pom_s1/dscp1+pom_s16*dscp1**4)
6486         pom2=(sumene4*cost2tab(i+1)+sumene2) &
6487            *(pom_s2/dscp2+pom_s26*dscp2**4)
6488         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6489         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2 &
6490         +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2) &
6491         +x(40)*yy*zz
6492         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6493         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2 &
6494         +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2) &
6495         +x(60)*yy*zz
6496         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6) &
6497               +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6) &
6498               +(pom1+pom2)*pom_dx
6499 #ifdef DEBUG
6500         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i,1)
6501 #endif
6502 !
6503         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6504         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2 &
6505         +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2) &
6506         +x(40)*xx*zz
6507         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6508         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz &
6509         +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz &
6510         +x(59)*zz**2 +x(60)*xx*zz
6511         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6) &
6512               +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6) &
6513               +(pom1-pom2)*pom_dy
6514 #ifdef DEBUG
6515         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i,1)
6516 #endif
6517 !
6518         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy &
6519         +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx &
6520         +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6) &
6521         +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6) &
6522         +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2 &
6523         +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy &
6524         +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6) &
6525         + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6526 #ifdef DEBUG
6527         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i,1)
6528 #endif
6529 !
6530         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6) &
6531         -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6) &
6532         +pom1*pom_dt1+pom2*pom_dt2
6533 #ifdef DEBUG
6534         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i,1)
6535 #endif
6536 !
6537 !
6538        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6539        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6540        cosfac2xx=cosfac2*xx
6541        sinfac2yy=sinfac2*yy
6542        do k = 1,3
6543          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))* &
6544             vbld_inv(i+1)
6545          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))* &
6546             vbld_inv(i)
6547          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6548          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6549 !         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6550 !     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6551 !         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6552 !     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6553          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6554          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6555          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6556          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6557          dZZ_Ci1(k)=0.0d0
6558          dZZ_Ci(k)=0.0d0
6559          do j=1,3
6560            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1) &
6561            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6562            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1) &
6563            *dsign(1.0d0,dfloat(itype(i,1)))*dC_norm(j,i+nres)
6564          enddo
6565
6566          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6567          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6568          dZZ_XYZ(k)=vbld_inv(i+nres)* &
6569          (z_prime(k)-zz*dC_norm(k,i+nres))
6570 !
6571          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6572          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6573        enddo
6574
6575        do k=1,3
6576          dXX_Ctab(k,i)=dXX_Ci(k)
6577          dXX_C1tab(k,i)=dXX_Ci1(k)
6578          dYY_Ctab(k,i)=dYY_Ci(k)
6579          dYY_C1tab(k,i)=dYY_Ci1(k)
6580          dZZ_Ctab(k,i)=dZZ_Ci(k)
6581          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6582          dXX_XYZtab(k,i)=dXX_XYZ(k)
6583          dYY_XYZtab(k,i)=dYY_XYZ(k)
6584          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6585        enddo
6586
6587        do k = 1,3
6588 !         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6589 !     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6590 !         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6591 !     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6592 !         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6593 !     &    dt_dci(k)
6594 !         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6595 !     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6596          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k) &
6597           +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6598          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k) &
6599           +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6600          gsclocx(k,i)=            de_dxx*dxx_XYZ(k) &
6601           +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6602        enddo
6603 !       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6604 !     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6605
6606 ! to check gradient call subroutine check_grad
6607
6608     1 continue
6609       enddo
6610       return
6611       end subroutine esc
6612 !-----------------------------------------------------------------------------
6613       real(kind=8) function enesc(x,xx,yy,zz,cost2,sint2)
6614 !      implicit none
6615       real(kind=8),dimension(65) :: x
6616       real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2,sumene3,&
6617         sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
6618
6619       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2 &
6620         + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy &
6621         + x(10)*yy*zz
6622       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2 &
6623         + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy &
6624         + x(20)*yy*zz
6625       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2 &
6626         +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy &
6627         +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3 &
6628         +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx &
6629         +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy &
6630         +x(40)*xx*yy*zz
6631       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2 &
6632         +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy &
6633         +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3 &
6634         +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx &
6635         +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy &
6636         +x(60)*xx*yy*zz
6637       dsc_i   = 0.743d0+x(61)
6638       dp2_i   = 1.9d0+x(62)
6639       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6640                 *(xx*cost2+yy*sint2))
6641       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i &
6642                 *(xx*cost2-yy*sint2))
6643       s1=(1+x(63))/(0.1d0 + dscp1)
6644       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6645       s2=(1+x(65))/(0.1d0 + dscp2)
6646       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6647       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6) &
6648        + (sumene4*cost2 +sumene2)*(s2+s2_6)
6649       enesc=sumene
6650       return
6651       end function enesc
6652 #endif
6653 !-----------------------------------------------------------------------------
6654       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6655 !
6656 ! This procedure calculates two-body contact function g(rij) and its derivative:
6657 !
6658 !           eps0ij                                     !       x < -1
6659 ! g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6660 !            0                                         !       x > 1
6661 !
6662 ! where x=(rij-r0ij)/delta
6663 !
6664 ! rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6665 !
6666 !      implicit none
6667       real(kind=8) :: rij,r0ij,eps0ij,fcont,fprimcont
6668       real(kind=8) :: x,x2,x4,delta
6669 !     delta=0.02D0*r0ij
6670 !      delta=0.2D0*r0ij
6671       x=(rij-r0ij)/delta
6672       if (x.lt.-1.0D0) then
6673         fcont=eps0ij
6674         fprimcont=0.0D0
6675       else if (x.le.1.0D0) then
6676         x2=x*x
6677         x4=x2*x2
6678         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
6679         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
6680       else
6681         fcont=0.0D0
6682         fprimcont=0.0D0
6683       endif
6684       return
6685       end subroutine gcont
6686 !-----------------------------------------------------------------------------
6687       subroutine splinthet(theti,delta,ss,ssder)
6688 !      implicit real*8 (a-h,o-z)
6689 !      include 'DIMENSIONS'
6690 !      include 'COMMON.VAR'
6691 !      include 'COMMON.GEO'
6692       real(kind=8) :: theti,delta,ss,ssder
6693       real(kind=8) :: thetup,thetlow
6694       thetup=pi-delta
6695       thetlow=delta
6696       if (theti.gt.pipol) then
6697         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
6698       else
6699         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
6700         ssder=-ssder
6701       endif
6702       return
6703       end subroutine splinthet
6704 !-----------------------------------------------------------------------------
6705       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
6706 !      implicit none
6707       real(kind=8) :: x,x0,delta,f0,f1,fprim0,f,fprim
6708       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6709       a1=fprim0*delta/(f1-f0)
6710       a2=3.0d0-2.0d0*a1
6711       a3=a1-2.0d0
6712       ksi=(x-x0)/delta
6713       ksi2=ksi*ksi
6714       ksi3=ksi2*ksi
6715       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
6716       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
6717       return
6718       end subroutine spline1
6719 !-----------------------------------------------------------------------------
6720       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
6721 !      implicit none
6722       real(kind=8) :: x,x0,delta,f0x,f1x,fprim0x,fx
6723       real(kind=8) :: ksi,ksi2,ksi3,a1,a2,a3
6724       ksi=(x-x0)/delta
6725       ksi2=ksi*ksi
6726       ksi3=ksi2*ksi
6727       a1=fprim0x*delta
6728       a2=3*(f1x-f0x)-2*fprim0x*delta
6729       a3=fprim0x*delta-2*(f1x-f0x)
6730       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
6731       return
6732       end subroutine spline2
6733 !-----------------------------------------------------------------------------
6734 #ifdef CRYST_TOR
6735 !-----------------------------------------------------------------------------
6736       subroutine etor(etors,edihcnstr)
6737 !      implicit real*8 (a-h,o-z)
6738 !      include 'DIMENSIONS'
6739 !      include 'COMMON.VAR'
6740 !      include 'COMMON.GEO'
6741 !      include 'COMMON.LOCAL'
6742 !      include 'COMMON.TORSION'
6743 !      include 'COMMON.INTERACT'
6744 !      include 'COMMON.DERIV'
6745 !      include 'COMMON.CHAIN'
6746 !      include 'COMMON.NAMES'
6747 !      include 'COMMON.IOUNITS'
6748 !      include 'COMMON.FFIELD'
6749 !      include 'COMMON.TORCNSTR'
6750 !      include 'COMMON.CONTROL'
6751       real(kind=8) :: etors,edihcnstr
6752       logical :: lprn
6753 !el local variables
6754       integer :: i,j,
6755       real(kind=8) :: phii,fac,etors_ii
6756
6757 ! Set lprn=.true. for debugging
6758       lprn=.false.
6759 !      lprn=.true.
6760       etors=0.0D0
6761       do i=iphi_start,iphi_end
6762       etors_ii=0.0D0
6763         if (itype(i-2,1).eq.ntyp1.or. itype(i-1,1).eq.ntyp1 &
6764             .or. itype(i,1).eq.ntyp1) cycle
6765         itori=itortyp(itype(i-2,1))
6766         itori1=itortyp(itype(i-1,1))
6767         phii=phi(i)
6768         gloci=0.0D0
6769 ! Proline-Proline pair is a special case...
6770         if (itori.eq.3 .and. itori1.eq.3) then
6771           if (phii.gt.-dwapi3) then
6772             cosphi=dcos(3*phii)
6773             fac=1.0D0/(1.0D0-cosphi)
6774             etorsi=v1(1,3,3)*fac
6775             etorsi=etorsi+etorsi
6776             etors=etors+etorsi-v1(1,3,3)
6777             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
6778             gloci=gloci-3*fac*etorsi*dsin(3*phii)
6779           endif
6780           do j=1,3
6781             v1ij=v1(j+1,itori,itori1)
6782             v2ij=v2(j+1,itori,itori1)
6783             cosphi=dcos(j*phii)
6784             sinphi=dsin(j*phii)
6785             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6786             if (energy_dec) etors_ii=etors_ii+ &
6787                                    v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6788             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6789           enddo
6790         else
6791           do j=1,nterm_old
6792             v1ij=v1(j,itori,itori1)
6793             v2ij=v2(j,itori,itori1)
6794             cosphi=dcos(j*phii)
6795             sinphi=dsin(j*phii)
6796             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6797             if (energy_dec) etors_ii=etors_ii+ &
6798                        v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
6799             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6800           enddo
6801         endif
6802         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6803              'etor',i,etors_ii
6804         if (lprn) &
6805         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6806         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6807         (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
6808         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6809 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6810       enddo
6811 ! 6/20/98 - dihedral angle constraints
6812       edihcnstr=0.0d0
6813       do i=1,ndih_constr
6814         itori=idih_constr(i)
6815         phii=phi(itori)
6816         difi=phii-phi0(i)
6817         if (difi.gt.drange(i)) then
6818           difi=difi-drange(i)
6819           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6820           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6821         else if (difi.lt.-drange(i)) then
6822           difi=difi+drange(i)
6823           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6824           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6825         endif
6826 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6827 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6828       enddo
6829 !      write (iout,*) 'edihcnstr',edihcnstr
6830       return
6831       end subroutine etor
6832 !-----------------------------------------------------------------------------
6833       subroutine etor_d(etors_d)
6834       real(kind=8) :: etors_d
6835       etors_d=0.0d0
6836       return
6837       end subroutine etor_d
6838 #else
6839 !-----------------------------------------------------------------------------
6840       subroutine etor(etors,edihcnstr)
6841 !      implicit real*8 (a-h,o-z)
6842 !      include 'DIMENSIONS'
6843 !      include 'COMMON.VAR'
6844 !      include 'COMMON.GEO'
6845 !      include 'COMMON.LOCAL'
6846 !      include 'COMMON.TORSION'
6847 !      include 'COMMON.INTERACT'
6848 !      include 'COMMON.DERIV'
6849 !      include 'COMMON.CHAIN'
6850 !      include 'COMMON.NAMES'
6851 !      include 'COMMON.IOUNITS'
6852 !      include 'COMMON.FFIELD'
6853 !      include 'COMMON.TORCNSTR'
6854 !      include 'COMMON.CONTROL'
6855       real(kind=8) :: etors,edihcnstr
6856       logical :: lprn
6857 !el local variables
6858       integer :: i,j,iblock,itori,itori1
6859       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
6860                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
6861 ! Set lprn=.true. for debugging
6862       lprn=.false.
6863 !     lprn=.true.
6864       etors=0.0D0
6865       do i=iphi_start,iphi_end
6866         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6867              .or. itype(i-3,1).eq.ntyp1 &
6868              .or. itype(i,1).eq.ntyp1) cycle
6869         etors_ii=0.0D0
6870          if (iabs(itype(i,1)).eq.20) then
6871          iblock=2
6872          else
6873          iblock=1
6874          endif
6875         itori=itortyp(itype(i-2,1))
6876         itori1=itortyp(itype(i-1,1))
6877         phii=phi(i)
6878         gloci=0.0D0
6879 ! Regular cosine and sine terms
6880         do j=1,nterm(itori,itori1,iblock)
6881           v1ij=v1(j,itori,itori1,iblock)
6882           v2ij=v2(j,itori,itori1,iblock)
6883           cosphi=dcos(j*phii)
6884           sinphi=dsin(j*phii)
6885           etors=etors+v1ij*cosphi+v2ij*sinphi
6886           if (energy_dec) etors_ii=etors_ii+ &
6887                      v1ij*cosphi+v2ij*sinphi
6888           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6889         enddo
6890 ! Lorentz terms
6891 !                         v1
6892 !  E = SUM ----------------------------------- - v1
6893 !          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
6894 !
6895         cosphi=dcos(0.5d0*phii)
6896         sinphi=dsin(0.5d0*phii)
6897         do j=1,nlor(itori,itori1,iblock)
6898           vl1ij=vlor1(j,itori,itori1)
6899           vl2ij=vlor2(j,itori,itori1)
6900           vl3ij=vlor3(j,itori,itori1)
6901           pom=vl2ij*cosphi+vl3ij*sinphi
6902           pom1=1.0d0/(pom*pom+1.0d0)
6903           etors=etors+vl1ij*pom1
6904           if (energy_dec) etors_ii=etors_ii+ &
6905                      vl1ij*pom1
6906           pom=-pom*pom1*pom1
6907           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
6908         enddo
6909 ! Subtract the constant term
6910         etors=etors-v0(itori,itori1,iblock)
6911           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
6912                'etor',i,etors_ii-v0(itori,itori1,iblock)
6913         if (lprn) &
6914         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
6915         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,itori,itori1,&
6916         (v1(j,itori,itori1,iblock),j=1,6),&
6917         (v2(j,itori,itori1,iblock),j=1,6)
6918         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
6919 !       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6920       enddo
6921 ! 6/20/98 - dihedral angle constraints
6922       edihcnstr=0.0d0
6923 !      do i=1,ndih_constr
6924       do i=idihconstr_start,idihconstr_end
6925         itori=idih_constr(i)
6926         phii=phi(itori)
6927         difi=pinorm(phii-phi0(i))
6928         if (difi.gt.drange(i)) then
6929           difi=difi-drange(i)
6930           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6931           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6932         else if (difi.lt.-drange(i)) then
6933           difi=difi+drange(i)
6934           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6935           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6936         else
6937           difi=0.0
6938         endif
6939 !d        write (iout,'(2i5,4f8.3,2e14.5)') i,itori,rad2deg*phii,
6940 !d     &    rad2deg*phi0(i),  rad2deg*drange(i),
6941 !d     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6942       enddo
6943 !d       write (iout,*) 'edihcnstr',edihcnstr
6944       return
6945       end subroutine etor
6946 !-----------------------------------------------------------------------------
6947       subroutine etor_d(etors_d)
6948 ! 6/23/01 Compute double torsional energy
6949 !      implicit real*8 (a-h,o-z)
6950 !      include 'DIMENSIONS'
6951 !      include 'COMMON.VAR'
6952 !      include 'COMMON.GEO'
6953 !      include 'COMMON.LOCAL'
6954 !      include 'COMMON.TORSION'
6955 !      include 'COMMON.INTERACT'
6956 !      include 'COMMON.DERIV'
6957 !      include 'COMMON.CHAIN'
6958 !      include 'COMMON.NAMES'
6959 !      include 'COMMON.IOUNITS'
6960 !      include 'COMMON.FFIELD'
6961 !      include 'COMMON.TORCNSTR'
6962       real(kind=8) :: etors_d,etors_d_ii
6963       logical :: lprn
6964 !el local variables
6965       integer :: i,j,k,l,itori,itori1,itori2,iblock
6966       real(kind=8) :: phii,phii1,gloci1,gloci2,&
6967                    v1cij,v1sij,v2cij,v2sij,cosphi1,sinphi1,&
6968                    sinphi2,cosphi2,v1cdij,v2cdij,v1sdij,v2sdij,&
6969                    cosphi1p2,cosphi1m2,sinphi1p2,sinphi1m2
6970 ! Set lprn=.true. for debugging
6971       lprn=.false.
6972 !     lprn=.true.
6973       etors_d=0.0D0
6974 !      write(iout,*) "a tu??"
6975       do i=iphid_start,iphid_end
6976         etors_d_ii=0.0D0
6977         if (itype(i-2,1).eq.ntyp1 .or. itype(i-1,1).eq.ntyp1 &
6978             .or. itype(i-3,1).eq.ntyp1 &
6979             .or. itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
6980         itori=itortyp(itype(i-2,1))
6981         itori1=itortyp(itype(i-1,1))
6982         itori2=itortyp(itype(i,1))
6983         phii=phi(i)
6984         phii1=phi(i+1)
6985         gloci1=0.0D0
6986         gloci2=0.0D0
6987         iblock=1
6988         if (iabs(itype(i+1,1)).eq.20) iblock=2
6989
6990 ! Regular cosine and sine terms
6991         do j=1,ntermd_1(itori,itori1,itori2,iblock)
6992           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6993           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6994           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6995           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6996           cosphi1=dcos(j*phii)
6997           sinphi1=dsin(j*phii)
6998           cosphi2=dcos(j*phii1)
6999           sinphi2=dsin(j*phii1)
7000           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+ &
7001            v2cij*cosphi2+v2sij*sinphi2
7002           if (energy_dec) etors_d_ii=etors_d_ii+ &
7003            v1cij*cosphi1+v1sij*sinphi1+v2cij*cosphi2+v2sij*sinphi2
7004           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7005           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7006         enddo
7007         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7008           do l=1,k-1
7009             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7010             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7011             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7012             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7013             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7014             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7015             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7016             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7017             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7018               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7019             if (energy_dec) etors_d_ii=etors_d_ii+ &
7020               v1cdij*cosphi1p2+v2cdij*cosphi1m2+ &
7021               v1sdij*sinphi1p2+v2sdij*sinphi1m2
7022             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2 &
7023               -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7024             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2 &
7025               -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7026           enddo
7027         enddo
7028         if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
7029                             'etor_d',i,etors_d_ii
7030         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7031         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7032       enddo
7033       return
7034       end subroutine etor_d
7035 #endif
7036 !-----------------------------------------------------------------------------
7037       subroutine eback_sc_corr(esccor)
7038 ! 7/21/2007 Correlations between the backbone-local and side-chain-local
7039 !        conformational states; temporarily implemented as differences
7040 !        between UNRES torsional potentials (dependent on three types of
7041 !        residues) and the torsional potentials dependent on all 20 types
7042 !        of residues computed from AM1  energy surfaces of terminally-blocked
7043 !        amino-acid residues.
7044 !      implicit real*8 (a-h,o-z)
7045 !      include 'DIMENSIONS'
7046 !      include 'COMMON.VAR'
7047 !      include 'COMMON.GEO'
7048 !      include 'COMMON.LOCAL'
7049 !      include 'COMMON.TORSION'
7050 !      include 'COMMON.SCCOR'
7051 !      include 'COMMON.INTERACT'
7052 !      include 'COMMON.DERIV'
7053 !      include 'COMMON.CHAIN'
7054 !      include 'COMMON.NAMES'
7055 !      include 'COMMON.IOUNITS'
7056 !      include 'COMMON.FFIELD'
7057 !      include 'COMMON.CONTROL'
7058       real(kind=8) :: esccor,esccor_ii,phii,gloci,v1ij,v2ij,&
7059                    cosphi,sinphi
7060       logical :: lprn
7061       integer :: i,interty,j,isccori,isccori1,intertyp
7062 ! Set lprn=.true. for debugging
7063       lprn=.false.
7064 !      lprn=.true.
7065 !      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7066       esccor=0.0D0
7067       do i=itau_start,itau_end
7068         if ((itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1)) cycle
7069         esccor_ii=0.0D0
7070         isccori=isccortyp(itype(i-2,1))
7071         isccori1=isccortyp(itype(i-1,1))
7072
7073 !      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7074         phii=phi(i)
7075         do intertyp=1,3 !intertyp
7076          esccor_ii=0.0D0
7077 !c Added 09 May 2012 (Adasko)
7078 !c  Intertyp means interaction type of backbone mainchain correlation:
7079 !   1 = SC...Ca...Ca...Ca
7080 !   2 = Ca...Ca...Ca...SC
7081 !   3 = SC...Ca...Ca...SCi
7082         gloci=0.0D0
7083         if (((intertyp.eq.3).and.((itype(i-2,1).eq.10).or. &
7084             (itype(i-1,1).eq.10).or.(itype(i-2,1).eq.ntyp1).or. &
7085             (itype(i-1,1).eq.ntyp1))) &
7086           .or. ((intertyp.eq.1).and.((itype(i-2,1).eq.10) &
7087            .or.(itype(i-2,1).eq.ntyp1).or.(itype(i-1,1).eq.ntyp1) &
7088            .or.(itype(i,1).eq.ntyp1))) &
7089           .or.((intertyp.eq.2).and.((itype(i-1,1).eq.10).or. &
7090             (itype(i-1,1).eq.ntyp1).or.(itype(i-2,1).eq.ntyp1).or. &
7091             (itype(i-3,1).eq.ntyp1)))) cycle
7092         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1,1).eq.ntyp1)) cycle
7093         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres,1).eq.ntyp1)) &
7094        cycle
7095        do j=1,nterm_sccor(isccori,isccori1)
7096           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7097           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7098           cosphi=dcos(j*tauangle(intertyp,i))
7099           sinphi=dsin(j*tauangle(intertyp,i))
7100           if (energy_dec) esccor_ii=esccor_ii+v1ij*cosphi+v2ij*sinphi
7101           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7102           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7103         enddo
7104         if (energy_dec) write (iout,'(a6,i5,i2,0pf7.3)') &
7105                                 'esccor',i,intertyp,esccor_ii
7106 !      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7107         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7108         if (lprn) &
7109         write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
7110         restyp(itype(i-2,1),1),i-2,restyp(itype(i-1,1),1),i-1,isccori,isccori1,&
7111         (v1sccor(j,intertyp,isccori,isccori1),j=1,6),&
7112         (v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7113         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7114        enddo !intertyp
7115       enddo
7116
7117       return
7118       end subroutine eback_sc_corr
7119 !-----------------------------------------------------------------------------
7120       subroutine multibody(ecorr)
7121 ! This subroutine calculates multi-body contributions to energy following
7122 ! the idea of Skolnick et al. If side chains I and J make a contact and
7123 ! at the same time side chains I+1 and J+1 make a contact, an extra
7124 ! contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7125 !      implicit real*8 (a-h,o-z)
7126 !      include 'DIMENSIONS'
7127 !      include 'COMMON.IOUNITS'
7128 !      include 'COMMON.DERIV'
7129 !      include 'COMMON.INTERACT'
7130 !      include 'COMMON.CONTACTS'
7131       real(kind=8),dimension(3) :: gx,gx1
7132       logical :: lprn
7133       real(kind=8) :: ecorr
7134       integer :: i,j,ishift,i1,num_conti,num_conti1,j1,jj,kk
7135 ! Set lprn=.true. for debugging
7136       lprn=.false.
7137
7138       if (lprn) then
7139         write (iout,'(a)') 'Contact function values:'
7140         do i=nnt,nct-2
7141           write (iout,'(i2,20(1x,i2,f10.5))') &
7142               i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7143         enddo
7144       endif
7145       ecorr=0.0D0
7146
7147 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7148 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7149       do i=nnt,nct
7150         do j=1,3
7151           gradcorr(j,i)=0.0D0
7152           gradxorr(j,i)=0.0D0
7153         enddo
7154       enddo
7155       do i=nnt,nct-2
7156
7157         DO ISHIFT = 3,4
7158
7159         i1=i+ishift
7160         num_conti=num_cont(i)
7161         num_conti1=num_cont(i1)
7162         do jj=1,num_conti
7163           j=jcont(jj,i)
7164           do kk=1,num_conti1
7165             j1=jcont(kk,i1)
7166             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7167 !d          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7168 !d   &                   ' ishift=',ishift
7169 ! Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7170 ! The system gains extra energy.
7171               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7172             endif   ! j1==j+-ishift
7173           enddo     ! kk
7174         enddo       ! jj
7175
7176         ENDDO ! ISHIFT
7177
7178       enddo         ! i
7179       return
7180       end subroutine multibody
7181 !-----------------------------------------------------------------------------
7182       real(kind=8) function esccorr(i,j,k,l,jj,kk)
7183 !      implicit real*8 (a-h,o-z)
7184 !      include 'DIMENSIONS'
7185 !      include 'COMMON.IOUNITS'
7186 !      include 'COMMON.DERIV'
7187 !      include 'COMMON.INTERACT'
7188 !      include 'COMMON.CONTACTS'
7189       real(kind=8),dimension(3) :: gx,gx1
7190       logical :: lprn
7191       integer :: i,j,k,l,jj,kk,m,ll
7192       real(kind=8) :: eij,ekl
7193       lprn=.false.
7194       eij=facont(jj,i)
7195       ekl=facont(kk,k)
7196 !d    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7197 ! Calculate the multi-body contribution to energy.
7198 ! Calculate multi-body contributions to the gradient.
7199 !d    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7200 !d   & k,l,(gacont(m,kk,k),m=1,3)
7201       do m=1,3
7202         gx(m) =ekl*gacont(m,jj,i)
7203         gx1(m)=eij*gacont(m,kk,k)
7204         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7205         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7206         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7207         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7208       enddo
7209       do m=i,j-1
7210         do ll=1,3
7211           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7212         enddo
7213       enddo
7214       do m=k,l-1
7215         do ll=1,3
7216           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7217         enddo
7218       enddo
7219       esccorr=-eij*ekl
7220       return
7221       end function esccorr
7222 !-----------------------------------------------------------------------------
7223       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7224 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7225 !      implicit real*8 (a-h,o-z)
7226 !      include 'DIMENSIONS'
7227 !      include 'COMMON.IOUNITS'
7228 #ifdef MPI
7229       include "mpif.h"
7230 !      integer :: maxconts !max_cont=maxconts  =nres/4
7231       integer,parameter :: max_dim=26
7232       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7233       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7234 !el      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7235 !el      common /przechowalnia/ zapas
7236       integer :: status(MPI_STATUS_SIZE)
7237       integer,dimension((nres/4)*2) :: req !maxconts*2
7238       integer :: status_array(MPI_STATUS_SIZE,(nres/4)*2),nn,ireq,ierr
7239 #endif
7240 !      include 'COMMON.SETUP'
7241 !      include 'COMMON.FFIELD'
7242 !      include 'COMMON.DERIV'
7243 !      include 'COMMON.INTERACT'
7244 !      include 'COMMON.CONTACTS'
7245 !      include 'COMMON.CONTROL'
7246 !      include 'COMMON.LOCAL'
7247       real(kind=8),dimension(3) :: gx,gx1
7248       real(kind=8) :: time00,ecorr,ecorr5,ecorr6
7249       logical :: lprn,ldone
7250 !el local variables
7251       integer :: i,j,ii,k,n_corr,n_corr1,i1,num_conti,num_conti1,&
7252               jj,jp,kk,j1,jp1,jjc,iii,nnn,iproc
7253
7254 ! Set lprn=.true. for debugging
7255       lprn=.false.
7256 #ifdef MPI
7257 !      maxconts=nres/4
7258       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7259       n_corr=0
7260       n_corr1=0
7261       if (nfgtasks.le.1) goto 30
7262       if (lprn) then
7263         write (iout,'(a)') 'Contact function values before RECEIVE:'
7264         do i=nnt,nct-2
7265           write (iout,'(2i3,50(1x,i2,f5.2))') &
7266           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7267           j=1,num_cont_hb(i))
7268         enddo
7269       endif
7270       call flush(iout)
7271       do i=1,ntask_cont_from
7272         ncont_recv(i)=0
7273       enddo
7274       do i=1,ntask_cont_to
7275         ncont_sent(i)=0
7276       enddo
7277 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7278 !     & ntask_cont_to
7279 ! Make the list of contacts to send to send to other procesors
7280 !      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
7281 !      call flush(iout)
7282       do i=iturn3_start,iturn3_end
7283 !        write (iout,*) "make contact list turn3",i," num_cont",
7284 !     &    num_cont_hb(i)
7285         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
7286       enddo
7287       do i=iturn4_start,iturn4_end
7288 !        write (iout,*) "make contact list turn4",i," num_cont",
7289 !     &   num_cont_hb(i)
7290         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
7291       enddo
7292       do ii=1,nat_sent
7293         i=iat_sent(ii)
7294 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7295 !     &    num_cont_hb(i)
7296         do j=1,num_cont_hb(i)
7297         do k=1,4
7298           jjc=jcont_hb(j,i)
7299           iproc=iint_sent_local(k,jjc,ii)
7300 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7301           if (iproc.gt.0) then
7302             ncont_sent(iproc)=ncont_sent(iproc)+1
7303             nn=ncont_sent(iproc)
7304             zapas(1,nn,iproc)=i
7305             zapas(2,nn,iproc)=jjc
7306             zapas(3,nn,iproc)=facont_hb(j,i)
7307             zapas(4,nn,iproc)=ees0p(j,i)
7308             zapas(5,nn,iproc)=ees0m(j,i)
7309             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
7310             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
7311             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
7312             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
7313             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
7314             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
7315             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
7316             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
7317             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
7318             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
7319             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
7320             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
7321             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
7322             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
7323             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
7324             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
7325             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
7326             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
7327             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
7328             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
7329             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
7330           endif
7331         enddo
7332         enddo
7333       enddo
7334       if (lprn) then
7335       write (iout,*) &
7336         "Numbers of contacts to be sent to other processors",&
7337         (ncont_sent(i),i=1,ntask_cont_to)
7338       write (iout,*) "Contacts sent"
7339       do ii=1,ntask_cont_to
7340         nn=ncont_sent(ii)
7341         iproc=itask_cont_to(ii)
7342         write (iout,*) nn," contacts to processor",iproc,&
7343          " of CONT_TO_COMM group"
7344         do i=1,nn
7345           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7346         enddo
7347       enddo
7348       call flush(iout)
7349       endif
7350       CorrelType=477
7351       CorrelID=fg_rank+1
7352       CorrelType1=478
7353       CorrelID1=nfgtasks+fg_rank+1
7354       ireq=0
7355 ! Receive the numbers of needed contacts from other processors
7356       do ii=1,ntask_cont_from
7357         iproc=itask_cont_from(ii)
7358         ireq=ireq+1
7359         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7360           FG_COMM,req(ireq),IERR)
7361       enddo
7362 !      write (iout,*) "IRECV ended"
7363 !      call flush(iout)
7364 ! Send the number of contacts needed by other processors
7365       do ii=1,ntask_cont_to
7366         iproc=itask_cont_to(ii)
7367         ireq=ireq+1
7368         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7369           FG_COMM,req(ireq),IERR)
7370       enddo
7371 !      write (iout,*) "ISEND ended"
7372 !      write (iout,*) "number of requests (nn)",ireq
7373       call flush(iout)
7374       if (ireq.gt.0) &
7375         call MPI_Waitall(ireq,req,status_array,ierr)
7376 !      write (iout,*)
7377 !     &  "Numbers of contacts to be received from other processors",
7378 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7379 !      call flush(iout)
7380 ! Receive contacts
7381       ireq=0
7382       do ii=1,ntask_cont_from
7383         iproc=itask_cont_from(ii)
7384         nn=ncont_recv(ii)
7385 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7386 !     &   " of CONT_TO_COMM group"
7387         call flush(iout)
7388         if (nn.gt.0) then
7389           ireq=ireq+1
7390           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7391           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7392 !          write (iout,*) "ireq,req",ireq,req(ireq)
7393         endif
7394       enddo
7395 ! Send the contacts to processors that need them
7396       do ii=1,ntask_cont_to
7397         iproc=itask_cont_to(ii)
7398         nn=ncont_sent(ii)
7399 !        write (iout,*) nn," contacts to processor",iproc,
7400 !     &   " of CONT_TO_COMM group"
7401         if (nn.gt.0) then
7402           ireq=ireq+1
7403           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7404             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7405 !          write (iout,*) "ireq,req",ireq,req(ireq)
7406 !          do i=1,nn
7407 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7408 !          enddo
7409         endif
7410       enddo
7411 !      write (iout,*) "number of requests (contacts)",ireq
7412 !      write (iout,*) "req",(req(i),i=1,4)
7413 !      call flush(iout)
7414       if (ireq.gt.0) &
7415        call MPI_Waitall(ireq,req,status_array,ierr)
7416       do iii=1,ntask_cont_from
7417         iproc=itask_cont_from(iii)
7418         nn=ncont_recv(iii)
7419         if (lprn) then
7420         write (iout,*) "Received",nn," contacts from processor",iproc,&
7421          " of CONT_FROM_COMM group"
7422         call flush(iout)
7423         do i=1,nn
7424           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
7425         enddo
7426         call flush(iout)
7427         endif
7428         do i=1,nn
7429           ii=zapas_recv(1,i,iii)
7430 ! Flag the received contacts to prevent double-counting
7431           jj=-zapas_recv(2,i,iii)
7432 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7433 !          call flush(iout)
7434           nnn=num_cont_hb(ii)+1
7435           num_cont_hb(ii)=nnn
7436           jcont_hb(nnn,ii)=jj
7437           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
7438           ees0p(nnn,ii)=zapas_recv(4,i,iii)
7439           ees0m(nnn,ii)=zapas_recv(5,i,iii)
7440           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
7441           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
7442           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
7443           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
7444           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
7445           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
7446           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
7447           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
7448           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
7449           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
7450           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
7451           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
7452           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
7453           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
7454           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
7455           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
7456           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
7457           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
7458           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
7459           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
7460           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
7461         enddo
7462       enddo
7463       call flush(iout)
7464       if (lprn) then
7465         write (iout,'(a)') 'Contact function values after receive:'
7466         do i=nnt,nct-2
7467           write (iout,'(2i3,50(1x,i3,f5.2))') &
7468           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7469           j=1,num_cont_hb(i))
7470         enddo
7471         call flush(iout)
7472       endif
7473    30 continue
7474 #endif
7475       if (lprn) then
7476         write (iout,'(a)') 'Contact function values:'
7477         do i=nnt,nct-2
7478           write (iout,'(2i3,50(1x,i3,f5.2))') &
7479           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7480           j=1,num_cont_hb(i))
7481         enddo
7482       endif
7483       ecorr=0.0D0
7484
7485 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7486 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7487 ! Remove the loop below after debugging !!!
7488       do i=nnt,nct
7489         do j=1,3
7490           gradcorr(j,i)=0.0D0
7491           gradxorr(j,i)=0.0D0
7492         enddo
7493       enddo
7494 ! Calculate the local-electrostatic correlation terms
7495       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
7496         i1=i+1
7497         num_conti=num_cont_hb(i)
7498         num_conti1=num_cont_hb(i+1)
7499         do jj=1,num_conti
7500           j=jcont_hb(jj,i)
7501           jp=iabs(j)
7502           do kk=1,num_conti1
7503             j1=jcont_hb(kk,i1)
7504             jp1=iabs(j1)
7505 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,&
7506 !               ' jj=',jj,' kk=',kk,"jp=",jp,"jp1",jp1
7507             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7508                 .or. j.lt.0 .and. j1.gt.0) .and. &
7509                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7510 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7511 ! The system gains extra energy.
7512               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7513               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
7514                   'ecorrh',i,j,ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
7515               n_corr=n_corr+1
7516             else if (j1.eq.j) then
7517 ! Contacts I-J and I-(J+1) occur simultaneously.
7518 ! The system loses extra energy.
7519 !             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7520             endif
7521           enddo ! kk
7522           do kk=1,num_conti
7523             j1=jcont_hb(kk,i)
7524 !           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7525 !    &         ' jj=',jj,' kk=',kk
7526             if (j1.eq.j+1) then
7527 ! Contacts I-J and (I+1)-J occur simultaneously.
7528 ! The system loses extra energy.
7529 !             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7530             endif ! j1==j+1
7531           enddo ! kk
7532         enddo ! jj
7533       enddo ! i
7534       return
7535       end subroutine multibody_hb
7536 !-----------------------------------------------------------------------------
7537       subroutine add_hb_contact(ii,jj,itask)
7538 !      implicit real*8 (a-h,o-z)
7539 !      include "DIMENSIONS"
7540 !      include "COMMON.IOUNITS"
7541 !      include "COMMON.CONTACTS"
7542 !      integer,parameter :: maxconts=nres/4
7543       integer,parameter :: max_dim=26
7544       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7545 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks)
7546 !      common /przechowalnia/ zapas
7547       integer :: i,j,ii,jj,iproc,nn,jjc
7548       integer,dimension(4) :: itask
7549 !      write (iout,*) "itask",itask
7550       do i=1,2
7551         iproc=itask(i)
7552         if (iproc.gt.0) then
7553           do j=1,num_cont_hb(ii)
7554             jjc=jcont_hb(j,ii)
7555 !            write (iout,*) "i",ii," j",jj," jjc",jjc
7556             if (jjc.eq.jj) then
7557               ncont_sent(iproc)=ncont_sent(iproc)+1
7558               nn=ncont_sent(iproc)
7559               zapas(1,nn,iproc)=ii
7560               zapas(2,nn,iproc)=jjc
7561               zapas(3,nn,iproc)=facont_hb(j,ii)
7562               zapas(4,nn,iproc)=ees0p(j,ii)
7563               zapas(5,nn,iproc)=ees0m(j,ii)
7564               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
7565               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
7566               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
7567               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
7568               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
7569               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
7570               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
7571               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
7572               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
7573               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
7574               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
7575               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
7576               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
7577               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
7578               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
7579               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
7580               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
7581               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
7582               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
7583               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
7584               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
7585               exit
7586             endif
7587           enddo
7588         endif
7589       enddo
7590       return
7591       end subroutine add_hb_contact
7592 !-----------------------------------------------------------------------------
7593       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
7594 ! This subroutine calculates multi-body contributions to hydrogen-bonding
7595 !      implicit real*8 (a-h,o-z)
7596 !      include 'DIMENSIONS'
7597 !      include 'COMMON.IOUNITS'
7598       integer,parameter :: max_dim=70
7599 #ifdef MPI
7600       include "mpif.h"
7601 !      integer :: maxconts !max_cont=maxconts=nres/4
7602       integer :: source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7603       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7604 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7605 !      common /przechowalnia/ zapas
7606       integer :: status(MPI_STATUS_SIZE),req((nres/4)*2),&
7607         status_array(MPI_STATUS_SIZE,(nres/4)*2),jjc,iproc,ireq,nn,ind,&
7608         ierr,iii,nnn
7609 #endif
7610 !      include 'COMMON.SETUP'
7611 !      include 'COMMON.FFIELD'
7612 !      include 'COMMON.DERIV'
7613 !      include 'COMMON.LOCAL'
7614 !      include 'COMMON.INTERACT'
7615 !      include 'COMMON.CONTACTS'
7616 !      include 'COMMON.CHAIN'
7617 !      include 'COMMON.CONTROL'
7618       real(kind=8),dimension(3) :: gx,gx1
7619       integer,dimension(nres) :: num_cont_hb_old
7620       logical :: lprn,ldone
7621 !EL      double precision eello4,eello5,eelo6,eello_turn6
7622 !EL      external eello4,eello5,eello6,eello_turn6
7623 !el local variables
7624       integer :: i,ii,j,k,l,jj,kk,ll,mm,n_corr,n_corr1,num_conti,jp,&
7625               j1,jp1,i1,num_conti1
7626       real(kind=8) :: sqd1,sqd2,sred_geom,fac_prim1,fac_prim2,fprimcont
7627       real(kind=8) :: ecorr,ecorr5,ecorr6,eturn6
7628
7629 ! Set lprn=.true. for debugging
7630       lprn=.false.
7631       eturn6=0.0d0
7632 #ifdef MPI
7633 !      maxconts=nres/4
7634       if(.not.allocated(zapas)) allocate(zapas(max_dim,maxconts,nfgtasks))
7635       do i=1,nres
7636         num_cont_hb_old(i)=num_cont_hb(i)
7637       enddo
7638       n_corr=0
7639       n_corr1=0
7640       if (nfgtasks.le.1) goto 30
7641       if (lprn) then
7642         write (iout,'(a)') 'Contact function values before RECEIVE:'
7643         do i=nnt,nct-2
7644           write (iout,'(2i3,50(1x,i2,f5.2))') &
7645           i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),&
7646           j=1,num_cont_hb(i))
7647         enddo
7648       endif
7649       call flush(iout)
7650       do i=1,ntask_cont_from
7651         ncont_recv(i)=0
7652       enddo
7653       do i=1,ntask_cont_to
7654         ncont_sent(i)=0
7655       enddo
7656 !      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
7657 !     & ntask_cont_to
7658 ! Make the list of contacts to send to send to other procesors
7659       do i=iturn3_start,iturn3_end
7660 !        write (iout,*) "make contact list turn3",i," num_cont",
7661 !     &    num_cont_hb(i)
7662         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
7663       enddo
7664       do i=iturn4_start,iturn4_end
7665 !        write (iout,*) "make contact list turn4",i," num_cont",
7666 !     &   num_cont_hb(i)
7667         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
7668       enddo
7669       do ii=1,nat_sent
7670         i=iat_sent(ii)
7671 !        write (iout,*) "make contact list longrange",i,ii," num_cont",
7672 !     &    num_cont_hb(i)
7673         do j=1,num_cont_hb(i)
7674         do k=1,4
7675           jjc=jcont_hb(j,i)
7676           iproc=iint_sent_local(k,jjc,ii)
7677 !          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
7678           if (iproc.ne.0) then
7679             ncont_sent(iproc)=ncont_sent(iproc)+1
7680             nn=ncont_sent(iproc)
7681             zapas(1,nn,iproc)=i
7682             zapas(2,nn,iproc)=jjc
7683             zapas(3,nn,iproc)=d_cont(j,i)
7684             ind=3
7685             do kk=1,3
7686               ind=ind+1
7687               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
7688             enddo
7689             do kk=1,2
7690               do ll=1,2
7691                 ind=ind+1
7692                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
7693               enddo
7694             enddo
7695             do jj=1,5
7696               do kk=1,3
7697                 do ll=1,2
7698                   do mm=1,2
7699                     ind=ind+1
7700                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
7701                   enddo
7702                 enddo
7703               enddo
7704             enddo
7705           endif
7706         enddo
7707         enddo
7708       enddo
7709       if (lprn) then
7710       write (iout,*) &
7711         "Numbers of contacts to be sent to other processors",&
7712         (ncont_sent(i),i=1,ntask_cont_to)
7713       write (iout,*) "Contacts sent"
7714       do ii=1,ntask_cont_to
7715         nn=ncont_sent(ii)
7716         iproc=itask_cont_to(ii)
7717         write (iout,*) nn," contacts to processor",iproc,&
7718          " of CONT_TO_COMM group"
7719         do i=1,nn
7720           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
7721         enddo
7722       enddo
7723       call flush(iout)
7724       endif
7725       CorrelType=477
7726       CorrelID=fg_rank+1
7727       CorrelType1=478
7728       CorrelID1=nfgtasks+fg_rank+1
7729       ireq=0
7730 ! Receive the numbers of needed contacts from other processors
7731       do ii=1,ntask_cont_from
7732         iproc=itask_cont_from(ii)
7733         ireq=ireq+1
7734         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,&
7735           FG_COMM,req(ireq),IERR)
7736       enddo
7737 !      write (iout,*) "IRECV ended"
7738 !      call flush(iout)
7739 ! Send the number of contacts needed by other processors
7740       do ii=1,ntask_cont_to
7741         iproc=itask_cont_to(ii)
7742         ireq=ireq+1
7743         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,&
7744           FG_COMM,req(ireq),IERR)
7745       enddo
7746 !      write (iout,*) "ISEND ended"
7747 !      write (iout,*) "number of requests (nn)",ireq
7748       call flush(iout)
7749       if (ireq.gt.0) &
7750         call MPI_Waitall(ireq,req,status_array,ierr)
7751 !      write (iout,*)
7752 !     &  "Numbers of contacts to be received from other processors",
7753 !     &  (ncont_recv(i),i=1,ntask_cont_from)
7754 !      call flush(iout)
7755 ! Receive contacts
7756       ireq=0
7757       do ii=1,ntask_cont_from
7758         iproc=itask_cont_from(ii)
7759         nn=ncont_recv(ii)
7760 !        write (iout,*) "Receiving",nn," contacts from processor",iproc,
7761 !     &   " of CONT_TO_COMM group"
7762         call flush(iout)
7763         if (nn.gt.0) then
7764           ireq=ireq+1
7765           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,&
7766           MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7767 !          write (iout,*) "ireq,req",ireq,req(ireq)
7768         endif
7769       enddo
7770 ! Send the contacts to processors that need them
7771       do ii=1,ntask_cont_to
7772         iproc=itask_cont_to(ii)
7773         nn=ncont_sent(ii)
7774 !        write (iout,*) nn," contacts to processor",iproc,
7775 !     &   " of CONT_TO_COMM group"
7776         if (nn.gt.0) then
7777           ireq=ireq+1
7778           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,&
7779             iproc,CorrelType1,FG_COMM,req(ireq),IERR)
7780 !          write (iout,*) "ireq,req",ireq,req(ireq)
7781 !          do i=1,nn
7782 !            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
7783 !          enddo
7784         endif
7785       enddo
7786 !      write (iout,*) "number of requests (contacts)",ireq
7787 !      write (iout,*) "req",(req(i),i=1,4)
7788 !      call flush(iout)
7789       if (ireq.gt.0) &
7790        call MPI_Waitall(ireq,req,status_array,ierr)
7791       do iii=1,ntask_cont_from
7792         iproc=itask_cont_from(iii)
7793         nn=ncont_recv(iii)
7794         if (lprn) then
7795         write (iout,*) "Received",nn," contacts from processor",iproc,&
7796          " of CONT_FROM_COMM group"
7797         call flush(iout)
7798         do i=1,nn
7799           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
7800         enddo
7801         call flush(iout)
7802         endif
7803         do i=1,nn
7804           ii=zapas_recv(1,i,iii)
7805 ! Flag the received contacts to prevent double-counting
7806           jj=-zapas_recv(2,i,iii)
7807 !          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
7808 !          call flush(iout)
7809           nnn=num_cont_hb(ii)+1
7810           num_cont_hb(ii)=nnn
7811           jcont_hb(nnn,ii)=jj
7812           d_cont(nnn,ii)=zapas_recv(3,i,iii)
7813           ind=3
7814           do kk=1,3
7815             ind=ind+1
7816             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
7817           enddo
7818           do kk=1,2
7819             do ll=1,2
7820               ind=ind+1
7821               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
7822             enddo
7823           enddo
7824           do jj=1,5
7825             do kk=1,3
7826               do ll=1,2
7827                 do mm=1,2
7828                   ind=ind+1
7829                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
7830                 enddo
7831               enddo
7832             enddo
7833           enddo
7834         enddo
7835       enddo
7836       call flush(iout)
7837       if (lprn) then
7838         write (iout,'(a)') 'Contact function values after receive:'
7839         do i=nnt,nct-2
7840           write (iout,'(2i3,50(1x,i3,5f6.3))') &
7841           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7842           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7843         enddo
7844         call flush(iout)
7845       endif
7846    30 continue
7847 #endif
7848       if (lprn) then
7849         write (iout,'(a)') 'Contact function values:'
7850         do i=nnt,nct-2
7851           write (iout,'(2i3,50(1x,i2,5f6.3))') &
7852           i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),&
7853           ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7854         enddo
7855       endif
7856       ecorr=0.0D0
7857       ecorr5=0.0d0
7858       ecorr6=0.0d0
7859
7860 !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres))
7861 !      if (.not.allocated(gradxorr)) allocate(gradxorr(3,nres))
7862 ! Remove the loop below after debugging !!!
7863       do i=nnt,nct
7864         do j=1,3
7865           gradcorr(j,i)=0.0D0
7866           gradxorr(j,i)=0.0D0
7867         enddo
7868       enddo
7869 ! Calculate the dipole-dipole interaction energies
7870       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7871       do i=iatel_s,iatel_e+1
7872         num_conti=num_cont_hb(i)
7873         do jj=1,num_conti
7874           j=jcont_hb(jj,i)
7875 #ifdef MOMENT
7876           call dipole(i,j,jj)
7877 #endif
7878         enddo
7879       enddo
7880       endif
7881 ! Calculate the local-electrostatic correlation terms
7882 !                write (iout,*) "gradcorr5 in eello5 before loop"
7883 !                do iii=1,nres
7884 !                  write (iout,'(i5,3f10.5)')
7885 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7886 !                enddo
7887       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7888 !        write (iout,*) "corr loop i",i
7889         i1=i+1
7890         num_conti=num_cont_hb(i)
7891         num_conti1=num_cont_hb(i+1)
7892         do jj=1,num_conti
7893           j=jcont_hb(jj,i)
7894           jp=iabs(j)
7895           do kk=1,num_conti1
7896             j1=jcont_hb(kk,i1)
7897             jp1=iabs(j1)
7898 !            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7899 !     &         ' jj=',jj,' kk=',kk
7900 !            if (j1.eq.j+1 .or. j1.eq.j-1) then
7901             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0 &
7902                 .or. j.lt.0 .and. j1.gt.0) .and. &
7903                (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7904 ! Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7905 ! The system gains extra energy.
7906               n_corr=n_corr+1
7907               sqd1=dsqrt(d_cont(jj,i))
7908               sqd2=dsqrt(d_cont(kk,i1))
7909               sred_geom = sqd1*sqd2
7910               IF (sred_geom.lt.cutoff_corr) THEN
7911                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,&
7912                   ekont,fprimcont)
7913 !d               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7914 !d     &         ' jj=',jj,' kk=',kk
7915                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7916                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7917                 do l=1,3
7918                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7919                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7920                 enddo
7921                 n_corr1=n_corr1+1
7922 !d               write (iout,*) 'sred_geom=',sred_geom,
7923 !d     &          ' ekont=',ekont,' fprim=',fprimcont,
7924 !d     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7925 !d               write (iout,*) "g_contij",g_contij
7926 !d               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7927 !d               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7928                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7929                 if (wcorr4.gt.0.0d0) &
7930                   ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7931                   if (energy_dec.and.wcorr4.gt.0.0d0) &
7932                        write (iout,'(a6,4i5,0pf7.3)') &
7933                       'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7934 !                write (iout,*) "gradcorr5 before eello5"
7935 !                do iii=1,nres
7936 !                  write (iout,'(i5,3f10.5)')
7937 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7938 !                enddo
7939                 if (wcorr5.gt.0.0d0) &
7940                   ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7941 !                write (iout,*) "gradcorr5 after eello5"
7942 !                do iii=1,nres
7943 !                  write (iout,'(i5,3f10.5)')
7944 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7945 !                enddo
7946                   if (energy_dec.and.wcorr5.gt.0.0d0) &
7947                        write (iout,'(a6,4i5,0pf7.3)') &
7948                       'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7949 !d                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7950 !d                write(2,*)'ijkl',i,jp,i+1,jp1
7951                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3 &
7952                      .or. wturn6.eq.0.0d0))then
7953 !d                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7954                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7955                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7956                       'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7957 !d                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7958 !d     &            'ecorr6=',ecorr6
7959 !d                write (iout,'(4e15.5)') sred_geom,
7960 !d     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7961 !d     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7962 !d     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7963                 else if (wturn6.gt.0.0d0 &
7964                   .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7965 !d                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
7966                   eturn6=eturn6+eello_turn6(i,jj,kk)
7967                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)') &
7968                        'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
7969 !d                  write (2,*) 'multibody_eello:eturn6',eturn6
7970                 endif
7971               ENDIF
7972 1111          continue
7973             endif
7974           enddo ! kk
7975         enddo ! jj
7976       enddo ! i
7977       do i=1,nres
7978         num_cont_hb(i)=num_cont_hb_old(i)
7979       enddo
7980 !                write (iout,*) "gradcorr5 in eello5"
7981 !                do iii=1,nres
7982 !                  write (iout,'(i5,3f10.5)')
7983 !     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7984 !                enddo
7985       return
7986       end subroutine multibody_eello
7987 !-----------------------------------------------------------------------------
7988       subroutine add_hb_contact_eello(ii,jj,itask)
7989 !      implicit real*8 (a-h,o-z)
7990 !      include "DIMENSIONS"
7991 !      include "COMMON.IOUNITS"
7992 !      include "COMMON.CONTACTS"
7993 !      integer,parameter :: maxconts=nres/4
7994       integer,parameter :: max_dim=70
7995       real(kind=8) :: zapas_recv(max_dim,maxconts,nfgtasks)
7996 !      real(kind=8) :: zapas(max_dim,maxconts,nfgtasks) !(max_dim,maxconts,max_fg_procs)
7997 !      common /przechowalnia/ zapas
7998
7999       integer :: i,j,ii,jj,iproc,nn,ind,jjc,kk,ll,mm
8000       integer,dimension(4) ::itask
8001 !      write (iout,*) "itask",itask
8002       do i=1,2
8003         iproc=itask(i)
8004         if (iproc.gt.0) then
8005           do j=1,num_cont_hb(ii)
8006             jjc=jcont_hb(j,ii)
8007 !            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8008             if (jjc.eq.jj) then
8009               ncont_sent(iproc)=ncont_sent(iproc)+1
8010               nn=ncont_sent(iproc)
8011               zapas(1,nn,iproc)=ii
8012               zapas(2,nn,iproc)=jjc
8013               zapas(3,nn,iproc)=d_cont(j,ii)
8014               ind=3
8015               do kk=1,3
8016                 ind=ind+1
8017                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8018               enddo
8019               do kk=1,2
8020                 do ll=1,2
8021                   ind=ind+1
8022                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8023                 enddo
8024               enddo
8025               do jj=1,5
8026                 do kk=1,3
8027                   do ll=1,2
8028                     do mm=1,2
8029                       ind=ind+1
8030                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8031                     enddo
8032                   enddo
8033                 enddo
8034               enddo
8035               exit
8036             endif
8037           enddo
8038         endif
8039       enddo
8040       return
8041       end subroutine add_hb_contact_eello
8042 !-----------------------------------------------------------------------------
8043       real(kind=8) function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8044 !      implicit real*8 (a-h,o-z)
8045 !      include 'DIMENSIONS'
8046 !      include 'COMMON.IOUNITS'
8047 !      include 'COMMON.DERIV'
8048 !      include 'COMMON.INTERACT'
8049 !      include 'COMMON.CONTACTS'
8050       real(kind=8),dimension(3) :: gx,gx1
8051       logical :: lprn
8052 !el local variables
8053       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
8054       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
8055                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
8056                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
8057                    rlocshield
8058
8059       lprn=.false.
8060       eij=facont_hb(jj,i)
8061       ekl=facont_hb(kk,k)
8062       ees0pij=ees0p(jj,i)
8063       ees0pkl=ees0p(kk,k)
8064       ees0mij=ees0m(jj,i)
8065       ees0mkl=ees0m(kk,k)
8066       ekont=eij*ekl
8067       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8068 !d    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8069 ! Following 4 lines for diagnostics.
8070 !d    ees0pkl=0.0D0
8071 !d    ees0pij=1.0D0
8072 !d    ees0mkl=0.0D0
8073 !d    ees0mij=1.0D0
8074 !      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8075 !     & 'Contacts ',i,j,
8076 !     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8077 !     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8078 !     & 'gradcorr_long'
8079 ! Calculate the multi-body contribution to energy.
8080 !      ecorr=ecorr+ekont*ees
8081 ! Calculate multi-body contributions to the gradient.
8082       coeffpees0pij=coeffp*ees0pij
8083       coeffmees0mij=coeffm*ees0mij
8084       coeffpees0pkl=coeffp*ees0pkl
8085       coeffmees0mkl=coeffm*ees0mkl
8086       do ll=1,3
8087 !grad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8088         gradcorr(ll,i)=gradcorr(ll,i) & !+0.5d0*ghalfi
8089         -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+ &
8090         coeffmees0mkl*gacontm_hb1(ll,jj,i))
8091         gradcorr(ll,j)=gradcorr(ll,j) & !+0.5d0*ghalfi
8092         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
8093         coeffmees0mkl*gacontm_hb2(ll,jj,i))
8094 !grad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8095         gradcorr(ll,k)=gradcorr(ll,k) & !+0.5d0*ghalfk
8096         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
8097         coeffmees0mij*gacontm_hb1(ll,kk,k))
8098         gradcorr(ll,l)=gradcorr(ll,l) & !+0.5d0*ghalfk
8099         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
8100         coeffmees0mij*gacontm_hb2(ll,kk,k))
8101         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
8102            ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
8103            coeffmees0mkl*gacontm_hb3(ll,jj,i))
8104         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8105         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8106         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
8107            ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
8108            coeffmees0mij*gacontm_hb3(ll,kk,k))
8109         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8110         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8111 !        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8112       enddo
8113 !      write (iout,*)
8114 !grad      do m=i+1,j-1
8115 !grad        do ll=1,3
8116 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8117 !grad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8118 !grad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8119 !grad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8120 !grad        enddo
8121 !grad      enddo
8122 !grad      do m=k+1,l-1
8123 !grad        do ll=1,3
8124 !grad          gradcorr(ll,m)=gradcorr(ll,m)+
8125 !grad     &     ees*eij*gacont_hbr(ll,kk,k)-
8126 !grad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8127 !grad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8128 !grad        enddo
8129 !grad      enddo
8130 !      write (iout,*) "ehbcorr",ekont*ees
8131       ehbcorr=ekont*ees
8132       if (shield_mode.gt.0) then
8133        j=ees0plist(jj,i)
8134        l=ees0plist(kk,k)
8135 !C        print *,i,j,fac_shield(i),fac_shield(j),
8136 !C     &fac_shield(k),fac_shield(l)
8137         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and. &
8138            (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8139           do ilist=1,ishield_list(i)
8140            iresshield=shield_list(ilist,i)
8141            do m=1,3
8142            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8143            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8144                    rlocshield  &
8145             +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8146             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8147             +rlocshield
8148            enddo
8149           enddo
8150           do ilist=1,ishield_list(j)
8151            iresshield=shield_list(ilist,j)
8152            do m=1,3
8153            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8154            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8155                    rlocshield &
8156             +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8157            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8158             +rlocshield
8159            enddo
8160           enddo
8161
8162           do ilist=1,ishield_list(k)
8163            iresshield=shield_list(ilist,k)
8164            do m=1,3
8165            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8166            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8167                    rlocshield &
8168             +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8169            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8170             +rlocshield
8171            enddo
8172           enddo
8173           do ilist=1,ishield_list(l)
8174            iresshield=shield_list(ilist,l)
8175            do m=1,3
8176            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8177            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+ &
8178                    rlocshield &
8179             +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8180            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1) &
8181             +rlocshield
8182            enddo
8183           enddo
8184           do m=1,3
8185             gshieldc_ec(m,i)=gshieldc_ec(m,i)+  &
8186                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8187             gshieldc_ec(m,j)=gshieldc_ec(m,j)+  &
8188                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8189             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+  &
8190                    grad_shield(m,i)*ehbcorr/fac_shield(i)
8191             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+  &
8192                    grad_shield(m,j)*ehbcorr/fac_shield(j)
8193
8194             gshieldc_ec(m,k)=gshieldc_ec(m,k)+  &
8195                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8196             gshieldc_ec(m,l)=gshieldc_ec(m,l)+  &
8197                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8198             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+  &
8199                    grad_shield(m,k)*ehbcorr/fac_shield(k)
8200             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+  &
8201                    grad_shield(m,l)*ehbcorr/fac_shield(l)
8202
8203            enddo
8204       endif
8205       endif
8206       return
8207       end function ehbcorr
8208 #ifdef MOMENT
8209 !-----------------------------------------------------------------------------
8210       subroutine dipole(i,j,jj)
8211 !      implicit real*8 (a-h,o-z)
8212 !      include 'DIMENSIONS'
8213 !      include 'COMMON.IOUNITS'
8214 !      include 'COMMON.CHAIN'
8215 !      include 'COMMON.FFIELD'
8216 !      include 'COMMON.DERIV'
8217 !      include 'COMMON.INTERACT'
8218 !      include 'COMMON.CONTACTS'
8219 !      include 'COMMON.TORSION'
8220 !      include 'COMMON.VAR'
8221 !      include 'COMMON.GEO'
8222       real(kind=8),dimension(2,2) :: dipi,dipj,auxmat
8223       real(kind=8),dimension(2) :: dipderi,dipderj,auxvec
8224       integer :: i,j,jj,iii,jjj,kkk,lll,iti1,itj1
8225
8226       allocate(dip(4,maxconts,nres),dipderg(4,maxconts,nres))
8227       allocate(dipderx(3,5,4,maxconts,nres))
8228 !
8229
8230       iti1 = itortyp(itype(i+1,1))
8231       if (j.lt.nres-1) then
8232         itj1 = itortyp(itype(j+1,1))
8233       else
8234         itj1=ntortyp+1
8235       endif
8236       do iii=1,2
8237         dipi(iii,1)=Ub2(iii,i)
8238         dipderi(iii)=Ub2der(iii,i)
8239         dipi(iii,2)=b1(iii,iti1)
8240         dipj(iii,1)=Ub2(iii,j)
8241         dipderj(iii)=Ub2der(iii,j)
8242         dipj(iii,2)=b1(iii,itj1)
8243       enddo
8244       kkk=0
8245       do iii=1,2
8246         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8247         do jjj=1,2
8248           kkk=kkk+1
8249           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8250         enddo
8251       enddo
8252       do kkk=1,5
8253         do lll=1,3
8254           mmm=0
8255           do iii=1,2
8256             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),&
8257               auxvec(1))
8258             do jjj=1,2
8259               mmm=mmm+1
8260               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8261             enddo
8262           enddo
8263         enddo
8264       enddo
8265       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8266       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8267       do iii=1,2
8268         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8269       enddo
8270       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8271       do iii=1,2
8272         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8273       enddo
8274       return
8275       end subroutine dipole
8276 #endif
8277 !-----------------------------------------------------------------------------
8278       subroutine calc_eello(i,j,k,l,jj,kk)
8279 !
8280 ! This subroutine computes matrices and vectors needed to calculate
8281 ! the fourth-, fifth-, and sixth-order local-electrostatic terms.
8282 !
8283       use comm_kut
8284 !      implicit real*8 (a-h,o-z)
8285 !      include 'DIMENSIONS'
8286 !      include 'COMMON.IOUNITS'
8287 !      include 'COMMON.CHAIN'
8288 !      include 'COMMON.DERIV'
8289 !      include 'COMMON.INTERACT'
8290 !      include 'COMMON.CONTACTS'
8291 !      include 'COMMON.TORSION'
8292 !      include 'COMMON.VAR'
8293 !      include 'COMMON.GEO'
8294 !      include 'COMMON.FFIELD'
8295       real(kind=8),dimension(2,2) :: aa1,aa2,aa1t,aa2t,auxmat
8296       real(kind=8),dimension(2,2,3,5) :: aa1tder,aa2tder
8297       integer :: i,j,k,l,jj,kk,iii,jjj,kkk,lll,iti,itk1,itj,itl,itl1,&
8298               itj1
8299 !el      logical :: lprn
8300 !el      common /kutas/ lprn
8301 !d      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8302 !d     & ' jj=',jj,' kk=',kk
8303 !d      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8304 !d      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8305 !d      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8306       do iii=1,2
8307         do jjj=1,2
8308           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8309           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8310         enddo
8311       enddo
8312       call transpose2(aa1(1,1),aa1t(1,1))
8313       call transpose2(aa2(1,1),aa2t(1,1))
8314       do kkk=1,5
8315         do lll=1,3
8316           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),&
8317             aa1tder(1,1,lll,kkk))
8318           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),&
8319             aa2tder(1,1,lll,kkk))
8320         enddo
8321       enddo
8322       if (l.eq.j+1) then
8323 ! parallel orientation of the two CA-CA-CA frames.
8324         if (i.gt.1) then
8325           iti=itortyp(itype(i,1))
8326         else
8327           iti=ntortyp+1
8328         endif
8329         itk1=itortyp(itype(k+1,1))
8330         itj=itortyp(itype(j,1))
8331         if (l.lt.nres-1) then
8332           itl1=itortyp(itype(l+1,1))
8333         else
8334           itl1=ntortyp+1
8335         endif
8336 ! A1 kernel(j+1) A2T
8337 !d        do iii=1,2
8338 !d          write (iout,'(3f10.5,5x,3f10.5)')
8339 !d     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8340 !d        enddo
8341         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8342          aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),&
8343          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8344 ! Following matrices are needed only for 6-th order cumulants
8345         IF (wcorr6.gt.0.0d0) THEN
8346         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8347          aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),&
8348          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8349         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8350          aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),&
8351          Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8352          ADtEAderx(1,1,1,1,1,1))
8353         lprn=.false.
8354         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8355          aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),&
8356          DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8357          ADtEA1derx(1,1,1,1,1,1))
8358         ENDIF
8359 ! End 6-th order cumulants
8360 !d        lprn=.false.
8361 !d        if (lprn) then
8362 !d        write (2,*) 'In calc_eello6'
8363 !d        do iii=1,2
8364 !d          write (2,*) 'iii=',iii
8365 !d          do kkk=1,5
8366 !d            write (2,*) 'kkk=',kkk
8367 !d            do jjj=1,2
8368 !d              write (2,'(3(2f10.5),5x)')
8369 !d     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8370 !d            enddo
8371 !d          enddo
8372 !d        enddo
8373 !d        endif
8374         call transpose2(EUgder(1,1,k),auxmat(1,1))
8375         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8376         call transpose2(EUg(1,1,k),auxmat(1,1))
8377         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8378         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8379         do iii=1,2
8380           do kkk=1,5
8381             do lll=1,3
8382               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8383                 EAEAderx(1,1,lll,kkk,iii,1))
8384             enddo
8385           enddo
8386         enddo
8387 ! A1T kernel(i+1) A2
8388         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8389          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),&
8390          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8391 ! Following matrices are needed only for 6-th order cumulants
8392         IF (wcorr6.gt.0.0d0) THEN
8393         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8394          a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),&
8395          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8396         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8397          a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),&
8398          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8399          ADtEAderx(1,1,1,1,1,2))
8400         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),&
8401          a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),&
8402          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8403          ADtEA1derx(1,1,1,1,1,2))
8404         ENDIF
8405 ! End 6-th order cumulants
8406         call transpose2(EUgder(1,1,l),auxmat(1,1))
8407         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8408         call transpose2(EUg(1,1,l),auxmat(1,1))
8409         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8410         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8411         do iii=1,2
8412           do kkk=1,5
8413             do lll=1,3
8414               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8415                 EAEAderx(1,1,lll,kkk,iii,2))
8416             enddo
8417           enddo
8418         enddo
8419 ! AEAb1 and AEAb2
8420 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8421 ! They are needed only when the fifth- or the sixth-order cumulants are
8422 ! indluded.
8423         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8424         call transpose2(AEA(1,1,1),auxmat(1,1))
8425         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8426         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8427         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8428         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8429         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8430         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8431         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8432         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8433         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8434         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8435         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8436         call transpose2(AEA(1,1,2),auxmat(1,1))
8437         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
8438         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8439         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8440         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8441         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
8442         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8443         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
8444         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
8445         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8446         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8447         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8448 ! Calculate the Cartesian derivatives of the vectors.
8449         do iii=1,2
8450           do kkk=1,5
8451             do lll=1,3
8452               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8453               call matvec2(auxmat(1,1),b1(1,iti),&
8454                 AEAb1derx(1,lll,kkk,iii,1,1))
8455               call matvec2(auxmat(1,1),Ub2(1,i),&
8456                 AEAb2derx(1,lll,kkk,iii,1,1))
8457               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8458                 AEAb1derx(1,lll,kkk,iii,2,1))
8459               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8460                 AEAb2derx(1,lll,kkk,iii,2,1))
8461               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8462               call matvec2(auxmat(1,1),b1(1,itj),&
8463                 AEAb1derx(1,lll,kkk,iii,1,2))
8464               call matvec2(auxmat(1,1),Ub2(1,j),&
8465                 AEAb2derx(1,lll,kkk,iii,1,2))
8466               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
8467                 AEAb1derx(1,lll,kkk,iii,2,2))
8468               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),&
8469                 AEAb2derx(1,lll,kkk,iii,2,2))
8470             enddo
8471           enddo
8472         enddo
8473         ENDIF
8474 ! End vectors
8475       else
8476 ! Antiparallel orientation of the two CA-CA-CA frames.
8477         if (i.gt.1) then
8478           iti=itortyp(itype(i,1))
8479         else
8480           iti=ntortyp+1
8481         endif
8482         itk1=itortyp(itype(k+1,1))
8483         itl=itortyp(itype(l,1))
8484         itj=itortyp(itype(j,1))
8485         if (j.lt.nres-1) then
8486           itj1=itortyp(itype(j+1,1))
8487         else
8488           itj1=ntortyp+1
8489         endif
8490 ! A2 kernel(j-1)T A1T
8491         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8492          aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),&
8493          AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8494 ! Following matrices are needed only for 6-th order cumulants
8495         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8496            j.eq.i+4 .and. l.eq.i+3)) THEN
8497         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8498          aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),&
8499          AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8500         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8501          aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),&
8502          Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),&
8503          ADtEAderx(1,1,1,1,1,1))
8504         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),&
8505          aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),&
8506          DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),&
8507          ADtEA1derx(1,1,1,1,1,1))
8508         ENDIF
8509 ! End 6-th order cumulants
8510         call transpose2(EUgder(1,1,k),auxmat(1,1))
8511         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8512         call transpose2(EUg(1,1,k),auxmat(1,1))
8513         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8514         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8515         do iii=1,2
8516           do kkk=1,5
8517             do lll=1,3
8518               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8519                 EAEAderx(1,1,lll,kkk,iii,1))
8520             enddo
8521           enddo
8522         enddo
8523 ! A2T kernel(i+1)T A1
8524         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8525          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),&
8526          AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8527 ! Following matrices are needed only for 6-th order cumulants
8528         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and. &
8529            j.eq.i+4 .and. l.eq.i+3)) THEN
8530         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8531          a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),&
8532          AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8533         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8534          a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),&
8535          Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),&
8536          ADtEAderx(1,1,1,1,1,2))
8537         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),&
8538          a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),&
8539          DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),&
8540          ADtEA1derx(1,1,1,1,1,2))
8541         ENDIF
8542 ! End 6-th order cumulants
8543         call transpose2(EUgder(1,1,j),auxmat(1,1))
8544         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8545         call transpose2(EUg(1,1,j),auxmat(1,1))
8546         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8547         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8548         do iii=1,2
8549           do kkk=1,5
8550             do lll=1,3
8551               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
8552                 EAEAderx(1,1,lll,kkk,iii,2))
8553             enddo
8554           enddo
8555         enddo
8556 ! AEAb1 and AEAb2
8557 ! Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8558 ! They are needed only when the fifth- or the sixth-order cumulants are
8559 ! indluded.
8560         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or. &
8561           (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8562         call transpose2(AEA(1,1,1),auxmat(1,1))
8563         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
8564         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8565         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8566         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8567         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
8568         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8569         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
8570         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
8571         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8572         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8573         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8574         call transpose2(AEA(1,1,2),auxmat(1,1))
8575         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
8576         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8577         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8578         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8579         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
8580         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8581         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
8582         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
8583         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8584         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8585         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8586 ! Calculate the Cartesian derivatives of the vectors.
8587         do iii=1,2
8588           do kkk=1,5
8589             do lll=1,3
8590               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8591               call matvec2(auxmat(1,1),b1(1,iti),&
8592                 AEAb1derx(1,lll,kkk,iii,1,1))
8593               call matvec2(auxmat(1,1),Ub2(1,i),&
8594                 AEAb2derx(1,lll,kkk,iii,1,1))
8595               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
8596                 AEAb1derx(1,lll,kkk,iii,2,1))
8597               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),&
8598                 AEAb2derx(1,lll,kkk,iii,2,1))
8599               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8600               call matvec2(auxmat(1,1),b1(1,itl),&
8601                 AEAb1derx(1,lll,kkk,iii,1,2))
8602               call matvec2(auxmat(1,1),Ub2(1,l),&
8603                 AEAb2derx(1,lll,kkk,iii,1,2))
8604               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),&
8605                 AEAb1derx(1,lll,kkk,iii,2,2))
8606               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),&
8607                 AEAb2derx(1,lll,kkk,iii,2,2))
8608             enddo
8609           enddo
8610         enddo
8611         ENDIF
8612 ! End vectors
8613       endif
8614       return
8615       end subroutine calc_eello
8616 !-----------------------------------------------------------------------------
8617       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,KK,KKderg,AKA,AKAderg,AKAderx)
8618       use comm_kut
8619       implicit none
8620       integer :: nderg
8621       logical :: transp
8622       real(kind=8),dimension(2,2) :: aa1,aa2t,KK,AKA
8623       real(kind=8),dimension(2,2,3,5) :: aa1derx,aa2tderx
8624       real(kind=8),dimension(2,2,3,5,2) :: AKAderx
8625       real(kind=8),dimension(2,2,nderg) :: KKderg,AKAderg
8626       integer :: iii,kkk,lll
8627       integer :: jjj,mmm
8628 !el      logical :: lprn
8629 !el      common /kutas/ lprn
8630       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8631       do iii=1,nderg
8632         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,&
8633           AKAderg(1,1,iii))
8634       enddo
8635 !d      if (lprn) write (2,*) 'In kernel'
8636       do kkk=1,5
8637 !d        if (lprn) write (2,*) 'kkk=',kkk
8638         do lll=1,3
8639           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),&
8640             KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8641 !d          if (lprn) then
8642 !d            write (2,*) 'lll=',lll
8643 !d            write (2,*) 'iii=1'
8644 !d            do jjj=1,2
8645 !d              write (2,'(3(2f10.5),5x)')
8646 !d     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8647 !d            enddo
8648 !d          endif
8649           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),&
8650             KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8651 !d          if (lprn) then
8652 !d            write (2,*) 'lll=',lll
8653 !d            write (2,*) 'iii=2'
8654 !d            do jjj=1,2
8655 !d              write (2,'(3(2f10.5),5x)')
8656 !d     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8657 !d            enddo
8658 !d          endif
8659         enddo
8660       enddo
8661       return
8662       end subroutine kernel
8663 !-----------------------------------------------------------------------------
8664       real(kind=8) function eello4(i,j,k,l,jj,kk)
8665 !      implicit real*8 (a-h,o-z)
8666 !      include 'DIMENSIONS'
8667 !      include 'COMMON.IOUNITS'
8668 !      include 'COMMON.CHAIN'
8669 !      include 'COMMON.DERIV'
8670 !      include 'COMMON.INTERACT'
8671 !      include 'COMMON.CONTACTS'
8672 !      include 'COMMON.TORSION'
8673 !      include 'COMMON.VAR'
8674 !      include 'COMMON.GEO'
8675       real(kind=8),dimension(2,2) :: pizda
8676       real(kind=8),dimension(3) :: ggg1,ggg2
8677       real(kind=8) ::  eel4,glongij,glongkl
8678       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
8679 !d      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8680 !d        eello4=0.0d0
8681 !d        return
8682 !d      endif
8683 !d      print *,'eello4:',i,j,k,l,jj,kk
8684 !d      write (2,*) 'i',i,' j',j,' k',k,' l',l
8685 !d      call checkint4(i,j,k,l,jj,kk,eel4_num)
8686 !old      eij=facont_hb(jj,i)
8687 !old      ekl=facont_hb(kk,k)
8688 !old      ekont=eij*ekl
8689       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8690 !d      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8691       gcorr_loc(k-1)=gcorr_loc(k-1) &
8692          -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8693       if (l.eq.j+1) then
8694         gcorr_loc(l-1)=gcorr_loc(l-1) &
8695            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8696       else
8697         gcorr_loc(j-1)=gcorr_loc(j-1) &
8698            -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8699       endif
8700       do iii=1,2
8701         do kkk=1,5
8702           do lll=1,3
8703             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1) &
8704                               -EAEAderx(2,2,lll,kkk,iii,1)
8705 !d            derx(lll,kkk,iii)=0.0d0
8706           enddo
8707         enddo
8708       enddo
8709 !d      gcorr_loc(l-1)=0.0d0
8710 !d      gcorr_loc(j-1)=0.0d0
8711 !d      gcorr_loc(k-1)=0.0d0
8712 !d      eel4=1.0d0
8713 !d      write (iout,*)'Contacts have occurred for peptide groups',
8714 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8715 !d     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8716       if (j.lt.nres-1) then
8717         j1=j+1
8718         j2=j-1
8719       else
8720         j1=j-1
8721         j2=j-2
8722       endif
8723       if (l.lt.nres-1) then
8724         l1=l+1
8725         l2=l-1
8726       else
8727         l1=l-1
8728         l2=l-2
8729       endif
8730       do ll=1,3
8731 !grad        ggg1(ll)=eel4*g_contij(ll,1)
8732 !grad        ggg2(ll)=eel4*g_contij(ll,2)
8733         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8734         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8735 !grad        ghalf=0.5d0*ggg1(ll)
8736         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8737         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8738         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8739         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8740         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8741         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8742 !grad        ghalf=0.5d0*ggg2(ll)
8743         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8744         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8745         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8746         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8747         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8748         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8749       enddo
8750 !grad      do m=i+1,j-1
8751 !grad        do ll=1,3
8752 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8753 !grad        enddo
8754 !grad      enddo
8755 !grad      do m=k+1,l-1
8756 !grad        do ll=1,3
8757 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8758 !grad        enddo
8759 !grad      enddo
8760 !grad      do m=i+2,j2
8761 !grad        do ll=1,3
8762 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8763 !grad        enddo
8764 !grad      enddo
8765 !grad      do m=k+2,l2
8766 !grad        do ll=1,3
8767 !grad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8768 !grad        enddo
8769 !grad      enddo
8770 !d      do iii=1,nres-3
8771 !d        write (2,*) iii,gcorr_loc(iii)
8772 !d      enddo
8773       eello4=ekont*eel4
8774 !d      write (2,*) 'ekont',ekont
8775 !d      write (iout,*) 'eello4',ekont*eel4
8776       return
8777       end function eello4
8778 !-----------------------------------------------------------------------------
8779       real(kind=8) function eello5(i,j,k,l,jj,kk)
8780 !      implicit real*8 (a-h,o-z)
8781 !      include 'DIMENSIONS'
8782 !      include 'COMMON.IOUNITS'
8783 !      include 'COMMON.CHAIN'
8784 !      include 'COMMON.DERIV'
8785 !      include 'COMMON.INTERACT'
8786 !      include 'COMMON.CONTACTS'
8787 !      include 'COMMON.TORSION'
8788 !      include 'COMMON.VAR'
8789 !      include 'COMMON.GEO'
8790       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
8791       real(kind=8),dimension(2) :: vv
8792       real(kind=8),dimension(3) :: ggg1,ggg2
8793       real(kind=8) :: eello5_1,eello5_2,eello5_3,eello5_4,eel5
8794       real(kind=8) :: gradcorr5ij,gradcorr5kl,ghalf
8795       integer :: i,j,k,l,jj,kk,itk,itl,itj,iii,kkk,lll,j1,j2,l1,l2,ll
8796 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8797 !                                                                              C
8798 !                            Parallel chains                                   C
8799 !                                                                              C
8800 !          o             o                   o             o                   C
8801 !         /l\           / \             \   / \           / \   /              C
8802 !        /   \         /   \             \ /   \         /   \ /               C
8803 !       j| o |l1       | o |                o| o |         | o |o                C
8804 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8805 !      \i/   \         /   \ /             /   \         /   \                 C
8806 !       o    k1             o                                                  C
8807 !         (I)          (II)                (III)          (IV)                 C
8808 !                                                                              C
8809 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8810 !                                                                              C
8811 !                            Antiparallel chains                               C
8812 !                                                                              C
8813 !          o             o                   o             o                   C
8814 !         /j\           / \             \   / \           / \   /              C
8815 !        /   \         /   \             \ /   \         /   \ /               C
8816 !      j1| o |l        | o |                o| o |         | o |o                C
8817 !     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8818 !      \i/   \         /   \ /             /   \         /   \                 C
8819 !       o     k1            o                                                  C
8820 !         (I)          (II)                (III)          (IV)                 C
8821 !                                                                              C
8822 !      eello5_1        eello5_2            eello5_3       eello5_4             C
8823 !                                                                              C
8824 ! o denotes a local interaction, vertical lines an electrostatic interaction.  C
8825 !                                                                              C
8826 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8827 !d      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8828 !d        eello5=0.0d0
8829 !d        return
8830 !d      endif
8831 !d      write (iout,*)
8832 !d     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8833 !d     &   ' and',k,l
8834       itk=itortyp(itype(k,1))
8835       itl=itortyp(itype(l,1))
8836       itj=itortyp(itype(j,1))
8837       eello5_1=0.0d0
8838       eello5_2=0.0d0
8839       eello5_3=0.0d0
8840       eello5_4=0.0d0
8841 !d      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8842 !d     &   eel5_3_num,eel5_4_num)
8843       do iii=1,2
8844         do kkk=1,5
8845           do lll=1,3
8846             derx(lll,kkk,iii)=0.0d0
8847           enddo
8848         enddo
8849       enddo
8850 !d      eij=facont_hb(jj,i)
8851 !d      ekl=facont_hb(kk,k)
8852 !d      ekont=eij*ekl
8853 !d      write (iout,*)'Contacts have occurred for peptide groups',
8854 !d     &  i,j,' fcont:',eij,' eij',' and ',k,l
8855 !d      goto 1111
8856 ! Contribution from the graph I.
8857 !d      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8858 !d      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8859       call transpose2(EUg(1,1,k),auxmat(1,1))
8860       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8861       vv(1)=pizda(1,1)-pizda(2,2)
8862       vv(2)=pizda(1,2)+pizda(2,1)
8863       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k)) &
8864        +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8865 ! Explicit gradient in virtual-dihedral angles.
8866       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1) &
8867        +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k)) &
8868        +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8869       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8870       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8871       vv(1)=pizda(1,1)-pizda(2,2)
8872       vv(2)=pizda(1,2)+pizda(2,1)
8873       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8874        +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k)) &
8875        +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8876       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8877       vv(1)=pizda(1,1)-pizda(2,2)
8878       vv(2)=pizda(1,2)+pizda(2,1)
8879       if (l.eq.j+1) then
8880         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8881          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8882          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8883       else
8884         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8885          +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k)) &
8886          +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8887       endif
8888 ! Cartesian gradient
8889       do iii=1,2
8890         do kkk=1,5
8891           do lll=1,3
8892             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),&
8893               pizda(1,1))
8894             vv(1)=pizda(1,1)-pizda(2,2)
8895             vv(2)=pizda(1,2)+pizda(2,1)
8896             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8897              +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k)) &
8898              +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8899           enddo
8900         enddo
8901       enddo
8902 !      goto 1112
8903 !1111  continue
8904 ! Contribution from graph II
8905       call transpose2(EE(1,1,itk),auxmat(1,1))
8906       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8907       vv(1)=pizda(1,1)+pizda(2,2)
8908       vv(2)=pizda(2,1)-pizda(1,2)
8909       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk)) &
8910        -0.5d0*scalar2(vv(1),Ctobr(1,k))
8911 ! Explicit gradient in virtual-dihedral angles.
8912       g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8913        -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8914       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8915       vv(1)=pizda(1,1)+pizda(2,2)
8916       vv(2)=pizda(2,1)-pizda(1,2)
8917       if (l.eq.j+1) then
8918         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8919          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8920          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8921       else
8922         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8923          +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk)) &
8924          -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8925       endif
8926 ! Cartesian gradient
8927       do iii=1,2
8928         do kkk=1,5
8929           do lll=1,3
8930             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),&
8931               pizda(1,1))
8932             vv(1)=pizda(1,1)+pizda(2,2)
8933             vv(2)=pizda(2,1)-pizda(1,2)
8934             derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8935              +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk)) &
8936              -0.5d0*scalar2(vv(1),Ctobr(1,k))
8937           enddo
8938         enddo
8939       enddo
8940 !d      goto 1112
8941 !d1111  continue
8942       if (l.eq.j+1) then
8943 !d        goto 1110
8944 ! Parallel orientation
8945 ! Contribution from graph III
8946         call transpose2(EUg(1,1,l),auxmat(1,1))
8947         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8948         vv(1)=pizda(1,1)-pizda(2,2)
8949         vv(2)=pizda(1,2)+pizda(2,1)
8950         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l)) &
8951          +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8952 ! Explicit gradient in virtual-dihedral angles.
8953         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
8954          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l)) &
8955          +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8956         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8957         vv(1)=pizda(1,1)-pizda(2,2)
8958         vv(2)=pizda(1,2)+pizda(2,1)
8959         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8960          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l)) &
8961          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8962         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8963         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8964         vv(1)=pizda(1,1)-pizda(2,2)
8965         vv(2)=pizda(1,2)+pizda(2,1)
8966         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8967          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l)) &
8968          +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8969 ! Cartesian gradient
8970         do iii=1,2
8971           do kkk=1,5
8972             do lll=1,3
8973               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
8974                 pizda(1,1))
8975               vv(1)=pizda(1,1)-pizda(2,2)
8976               vv(2)=pizda(1,2)+pizda(2,1)
8977               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
8978                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l)) &
8979                +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8980             enddo
8981           enddo
8982         enddo
8983 !d        goto 1112
8984 ! Contribution from graph IV
8985 !d1110    continue
8986         call transpose2(EE(1,1,itl),auxmat(1,1))
8987         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8988         vv(1)=pizda(1,1)+pizda(2,2)
8989         vv(2)=pizda(2,1)-pizda(1,2)
8990         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl)) &
8991          -0.5d0*scalar2(vv(1),Ctobr(1,l))
8992 ! Explicit gradient in virtual-dihedral angles.
8993         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
8994          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8995         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8996         vv(1)=pizda(1,1)+pizda(2,2)
8997         vv(2)=pizda(2,1)-pizda(1,2)
8998         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
8999          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl)) &
9000          -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9001 ! Cartesian gradient
9002         do iii=1,2
9003           do kkk=1,5
9004             do lll=1,3
9005               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9006                 pizda(1,1))
9007               vv(1)=pizda(1,1)+pizda(2,2)
9008               vv(2)=pizda(2,1)-pizda(1,2)
9009               derx(lll,kkk,iii)=derx(lll,kkk,iii) &
9010                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl)) &
9011                -0.5d0*scalar2(vv(1),Ctobr(1,l))
9012             enddo
9013           enddo
9014         enddo
9015       else
9016 ! Antiparallel orientation
9017 ! Contribution from graph III
9018 !        goto 1110
9019         call transpose2(EUg(1,1,j),auxmat(1,1))
9020         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9021         vv(1)=pizda(1,1)-pizda(2,2)
9022         vv(2)=pizda(1,2)+pizda(2,1)
9023         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j)) &
9024          +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9025 ! Explicit gradient in virtual-dihedral angles.
9026         g_corr5_loc(l-1)=g_corr5_loc(l-1) &
9027          +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j)) &
9028          +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9029         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9030         vv(1)=pizda(1,1)-pizda(2,2)
9031         vv(2)=pizda(1,2)+pizda(2,1)
9032         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9033          +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j)) &
9034          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9035         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9036         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9037         vv(1)=pizda(1,1)-pizda(2,2)
9038         vv(2)=pizda(1,2)+pizda(2,1)
9039         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9040          +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j)) &
9041          +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9042 ! Cartesian gradient
9043         do iii=1,2
9044           do kkk=1,5
9045             do lll=1,3
9046               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),&
9047                 pizda(1,1))
9048               vv(1)=pizda(1,1)-pizda(2,2)
9049               vv(2)=pizda(1,2)+pizda(2,1)
9050               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9051                +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j)) &
9052                +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9053             enddo
9054           enddo
9055         enddo
9056 !d        goto 1112
9057 ! Contribution from graph IV
9058 1110    continue
9059         call transpose2(EE(1,1,itj),auxmat(1,1))
9060         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9061         vv(1)=pizda(1,1)+pizda(2,2)
9062         vv(2)=pizda(2,1)-pizda(1,2)
9063         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj)) &
9064          -0.5d0*scalar2(vv(1),Ctobr(1,j))
9065 ! Explicit gradient in virtual-dihedral angles.
9066         g_corr5_loc(j-1)=g_corr5_loc(j-1) &
9067          -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9068         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9069         vv(1)=pizda(1,1)+pizda(2,2)
9070         vv(2)=pizda(2,1)-pizda(1,2)
9071         g_corr5_loc(k-1)=g_corr5_loc(k-1) &
9072          +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj)) &
9073          -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9074 ! Cartesian gradient
9075         do iii=1,2
9076           do kkk=1,5
9077             do lll=1,3
9078               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),&
9079                 pizda(1,1))
9080               vv(1)=pizda(1,1)+pizda(2,2)
9081               vv(2)=pizda(2,1)-pizda(1,2)
9082               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii) &
9083                +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj)) &
9084                -0.5d0*scalar2(vv(1),Ctobr(1,j))
9085             enddo
9086           enddo
9087         enddo
9088       endif
9089 1112  continue
9090       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9091 !d      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9092 !d        write (2,*) 'ijkl',i,j,k,l
9093 !d        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9094 !d     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9095 !d      endif
9096 !d      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9097 !d      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9098 !d      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9099 !d      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9100       if (j.lt.nres-1) then
9101         j1=j+1
9102         j2=j-1
9103       else
9104         j1=j-1
9105         j2=j-2
9106       endif
9107       if (l.lt.nres-1) then
9108         l1=l+1
9109         l2=l-1
9110       else
9111         l1=l-1
9112         l2=l-2
9113       endif
9114 !d      eij=1.0d0
9115 !d      ekl=1.0d0
9116 !d      ekont=1.0d0
9117 !d      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9118 ! 2/11/08 AL Gradients over DC's connecting interacting sites will be
9119 !        summed up outside the subrouine as for the other subroutines
9120 !        handling long-range interactions. The old code is commented out
9121 !        with "cgrad" to keep track of changes.
9122       do ll=1,3
9123 !grad        ggg1(ll)=eel5*g_contij(ll,1)
9124 !grad        ggg2(ll)=eel5*g_contij(ll,2)
9125         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9126         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9127 !        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9128 !     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9129 !     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9130 !     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9131 !        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9132 !     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9133 !     &   gradcorr5ij,
9134 !     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9135 !old        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9136 !grad        ghalf=0.5d0*ggg1(ll)
9137 !d        ghalf=0.0d0
9138         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9139         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9140         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9141         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9142         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9143         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9144 !old        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9145 !grad        ghalf=0.5d0*ggg2(ll)
9146         ghalf=0.0d0
9147         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
9148         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9149         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
9150         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9151         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9152         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9153       enddo
9154 !d      goto 1112
9155 !grad      do m=i+1,j-1
9156 !grad        do ll=1,3
9157 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9158 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9159 !grad        enddo
9160 !grad      enddo
9161 !grad      do m=k+1,l-1
9162 !grad        do ll=1,3
9163 !old          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9164 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9165 !grad        enddo
9166 !grad      enddo
9167 !1112  continue
9168 !grad      do m=i+2,j2
9169 !grad        do ll=1,3
9170 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9171 !grad        enddo
9172 !grad      enddo
9173 !grad      do m=k+2,l2
9174 !grad        do ll=1,3
9175 !grad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9176 !grad        enddo
9177 !grad      enddo
9178 !d      do iii=1,nres-3
9179 !d        write (2,*) iii,g_corr5_loc(iii)
9180 !d      enddo
9181       eello5=ekont*eel5
9182 !d      write (2,*) 'ekont',ekont
9183 !d      write (iout,*) 'eello5',ekont*eel5
9184       return
9185       end function eello5
9186 !-----------------------------------------------------------------------------
9187       real(kind=8) function eello6(i,j,k,l,jj,kk)
9188 !      implicit real*8 (a-h,o-z)
9189 !      include 'DIMENSIONS'
9190 !      include 'COMMON.IOUNITS'
9191 !      include 'COMMON.CHAIN'
9192 !      include 'COMMON.DERIV'
9193 !      include 'COMMON.INTERACT'
9194 !      include 'COMMON.CONTACTS'
9195 !      include 'COMMON.TORSION'
9196 !      include 'COMMON.VAR'
9197 !      include 'COMMON.GEO'
9198 !      include 'COMMON.FFIELD'
9199       real(kind=8),dimension(3) :: ggg1,ggg2
9200       real(kind=8) :: eello6_1,eello6_2,eello6_3,eello6_4,eello6_5,&
9201                    eello6_6,eel6
9202       real(kind=8) :: gradcorr6ij,gradcorr6kl
9203       integer :: i,j,k,l,jj,kk,iii,kkk,lll,j1,j2,l1,l2,ll
9204 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9205 !d        eello6=0.0d0
9206 !d        return
9207 !d      endif
9208 !d      write (iout,*)
9209 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9210 !d     &   ' and',k,l
9211       eello6_1=0.0d0
9212       eello6_2=0.0d0
9213       eello6_3=0.0d0
9214       eello6_4=0.0d0
9215       eello6_5=0.0d0
9216       eello6_6=0.0d0
9217 !d      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9218 !d     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9219       do iii=1,2
9220         do kkk=1,5
9221           do lll=1,3
9222             derx(lll,kkk,iii)=0.0d0
9223           enddo
9224         enddo
9225       enddo
9226 !d      eij=facont_hb(jj,i)
9227 !d      ekl=facont_hb(kk,k)
9228 !d      ekont=eij*ekl
9229 !d      eij=1.0d0
9230 !d      ekl=1.0d0
9231 !d      ekont=1.0d0
9232       if (l.eq.j+1) then
9233         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9234         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9235         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9236         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9237         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9238         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9239       else
9240         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9241         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9242         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9243         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9244         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9245           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9246         else
9247           eello6_5=0.0d0
9248         endif
9249         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9250       endif
9251 ! If turn contributions are considered, they will be handled separately.
9252       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9253 !d      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9254 !d      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9255 !d      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9256 !d      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9257 !d      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9258 !d      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9259 !d      goto 1112
9260       if (j.lt.nres-1) then
9261         j1=j+1
9262         j2=j-1
9263       else
9264         j1=j-1
9265         j2=j-2
9266       endif
9267       if (l.lt.nres-1) then
9268         l1=l+1
9269         l2=l-1
9270       else
9271         l1=l-1
9272         l2=l-2
9273       endif
9274       do ll=1,3
9275 !grad        ggg1(ll)=eel6*g_contij(ll,1)
9276 !grad        ggg2(ll)=eel6*g_contij(ll,2)
9277 !old        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9278 !grad        ghalf=0.5d0*ggg1(ll)
9279 !d        ghalf=0.0d0
9280         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9281         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9282         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9283         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9284         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9285         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9286         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9287         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9288 !grad        ghalf=0.5d0*ggg2(ll)
9289 !old        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9290 !d        ghalf=0.0d0
9291         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9292         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9293         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9294         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9295         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9296         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9297       enddo
9298 !d      goto 1112
9299 !grad      do m=i+1,j-1
9300 !grad        do ll=1,3
9301 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9302 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9303 !grad        enddo
9304 !grad      enddo
9305 !grad      do m=k+1,l-1
9306 !grad        do ll=1,3
9307 !old          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9308 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9309 !grad        enddo
9310 !grad      enddo
9311 !grad1112  continue
9312 !grad      do m=i+2,j2
9313 !grad        do ll=1,3
9314 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9315 !grad        enddo
9316 !grad      enddo
9317 !grad      do m=k+2,l2
9318 !grad        do ll=1,3
9319 !grad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9320 !grad        enddo
9321 !grad      enddo
9322 !d      do iii=1,nres-3
9323 !d        write (2,*) iii,g_corr6_loc(iii)
9324 !d      enddo
9325       eello6=ekont*eel6
9326 !d      write (2,*) 'ekont',ekont
9327 !d      write (iout,*) 'eello6',ekont*eel6
9328       return
9329       end function eello6
9330 !-----------------------------------------------------------------------------
9331       real(kind=8) function eello6_graph1(i,j,k,l,imat,swap)
9332       use comm_kut
9333 !      implicit real*8 (a-h,o-z)
9334 !      include 'DIMENSIONS'
9335 !      include 'COMMON.IOUNITS'
9336 !      include 'COMMON.CHAIN'
9337 !      include 'COMMON.DERIV'
9338 !      include 'COMMON.INTERACT'
9339 !      include 'COMMON.CONTACTS'
9340 !      include 'COMMON.TORSION'
9341 !      include 'COMMON.VAR'
9342 !      include 'COMMON.GEO'
9343       real(kind=8),dimension(2) :: vv,vv1
9344       real(kind=8),dimension(2,2) :: pizda,auxmat,pizda1
9345       logical :: swap
9346 !el      logical :: lprn
9347 !el      common /kutas/ lprn
9348       integer :: i,j,k,l,imat,itk,iii,kkk,lll,ind
9349       real(kind=8) :: s1,s2,s3,s4,s5
9350 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9351 !                                                                              C
9352 !      Parallel       Antiparallel                                             C
9353 !                                                                              C
9354 !          o             o                                                     C
9355 !         /l\           /j\                                                    C
9356 !        /   \         /   \                                                   C
9357 !       /| o |         | o |\                                                  C
9358 !     \ j|/k\|  /   \  |/k\|l /                                                C
9359 !      \ /   \ /     \ /   \ /                                                 C
9360 !       o     o       o     o                                                  C
9361 !       i             i                                                        C
9362 !                                                                              C
9363 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9364       itk=itortyp(itype(k,1))
9365       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9366       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9367       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9368       call transpose2(EUgC(1,1,k),auxmat(1,1))
9369       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9370       vv1(1)=pizda1(1,1)-pizda1(2,2)
9371       vv1(2)=pizda1(1,2)+pizda1(2,1)
9372       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9373       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
9374       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
9375       s5=scalar2(vv(1),Dtobr2(1,i))
9376 !d      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9377       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9378       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1) &
9379        -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i)) &
9380        -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k)) &
9381        +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k)) &
9382        +0.5d0*scalar2(vv1(1),Dtobr2der(1,i)) &
9383        +scalar2(vv(1),Dtobr2der(1,i)))
9384       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9385       vv1(1)=pizda1(1,1)-pizda1(2,2)
9386       vv1(2)=pizda1(1,2)+pizda1(2,1)
9387       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
9388       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
9389       if (l.eq.j+1) then
9390         g_corr6_loc(l-1)=g_corr6_loc(l-1) &
9391        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9392        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9393        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9394        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9395       else
9396         g_corr6_loc(j-1)=g_corr6_loc(j-1) &
9397        +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i)) &
9398        -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k)) &
9399        +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k)) &
9400        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9401       endif
9402       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9403       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9404       vv1(1)=pizda1(1,1)-pizda1(2,2)
9405       vv1(2)=pizda1(1,2)+pizda1(2,1)
9406       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1) &
9407        +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k)) &
9408        +scalar2(AEAb2(1,1,imat),CUgb2der(1,k)) &
9409        +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9410       do iii=1,2
9411         if (swap) then
9412           ind=3-iii
9413         else
9414           ind=iii
9415         endif
9416         do kkk=1,5
9417           do lll=1,3
9418             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9419             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9420             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9421             call transpose2(EUgC(1,1,k),auxmat(1,1))
9422             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9423               pizda1(1,1))
9424             vv1(1)=pizda1(1,1)-pizda1(2,2)
9425             vv1(2)=pizda1(1,2)+pizda1(2,1)
9426             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9427             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk) &
9428              -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
9429             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk) &
9430              +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
9431             s5=scalar2(vv(1),Dtobr2(1,i))
9432             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9433           enddo
9434         enddo
9435       enddo
9436       return
9437       end function eello6_graph1
9438 !-----------------------------------------------------------------------------
9439       real(kind=8) function eello6_graph2(i,j,k,l,jj,kk,swap)
9440       use comm_kut
9441 !      implicit real*8 (a-h,o-z)
9442 !      include 'DIMENSIONS'
9443 !      include 'COMMON.IOUNITS'
9444 !      include 'COMMON.CHAIN'
9445 !      include 'COMMON.DERIV'
9446 !      include 'COMMON.INTERACT'
9447 !      include 'COMMON.CONTACTS'
9448 !      include 'COMMON.TORSION'
9449 !      include 'COMMON.VAR'
9450 !      include 'COMMON.GEO'
9451       logical :: swap
9452       real(kind=8),dimension(2) :: vv,auxvec,auxvec1,auxvec2
9453       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9454 !el      logical :: lprn
9455 !el      common /kutas/ lprn
9456       integer :: i,j,k,l,jj,kk,iii,kkk,lll,jjj,mmm
9457       real(kind=8) :: s2,s3,s4
9458 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9459 !                                                                              C
9460 !      Parallel       Antiparallel                                             C
9461 !                                                                              C
9462 !          o             o                                                     C
9463 !     \   /l\           /j\   /                                                C
9464 !      \ /   \         /   \ /                                                 C
9465 !       o| o |         | o |o                                                  C
9466 !     \ j|/k\|      \  |/k\|l                                                  C
9467 !      \ /   \       \ /   \                                                   C
9468 !       o             o                                                        C
9469 !       i             i                                                        C
9470 !                                                                              C
9471 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9472 !d      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9473 ! AL 7/4/01 s1 would occur in the sixth-order moment,
9474 !           but not in a cluster cumulant
9475 #ifdef MOMENT
9476       s1=dip(1,jj,i)*dip(1,kk,k)
9477 #endif
9478       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9479       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9480       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9481       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9482       call transpose2(EUg(1,1,k),auxmat(1,1))
9483       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9484       vv(1)=pizda(1,1)-pizda(2,2)
9485       vv(2)=pizda(1,2)+pizda(2,1)
9486       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9487 !d      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9488 #ifdef MOMENT
9489       eello6_graph2=-(s1+s2+s3+s4)
9490 #else
9491       eello6_graph2=-(s2+s3+s4)
9492 #endif
9493 !      eello6_graph2=-s3
9494 ! Derivatives in gamma(i-1)
9495       if (i.gt.1) then
9496 #ifdef MOMENT
9497         s1=dipderg(1,jj,i)*dip(1,kk,k)
9498 #endif
9499         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9500         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9501         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9502         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9503 #ifdef MOMENT
9504         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9505 #else
9506         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9507 #endif
9508 !        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9509       endif
9510 ! Derivatives in gamma(k-1)
9511 #ifdef MOMENT
9512       s1=dip(1,jj,i)*dipderg(1,kk,k)
9513 #endif
9514       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9515       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9516       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9517       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9518       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9519       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9520       vv(1)=pizda(1,1)-pizda(2,2)
9521       vv(2)=pizda(1,2)+pizda(2,1)
9522       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9523 #ifdef MOMENT
9524       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9525 #else
9526       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9527 #endif
9528 !      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9529 ! Derivatives in gamma(j-1) or gamma(l-1)
9530       if (j.gt.1) then
9531 #ifdef MOMENT
9532         s1=dipderg(3,jj,i)*dip(1,kk,k)
9533 #endif
9534         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9535         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9536         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9537         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9538         vv(1)=pizda(1,1)-pizda(2,2)
9539         vv(2)=pizda(1,2)+pizda(2,1)
9540         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9541 #ifdef MOMENT
9542         if (swap) then
9543           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9544         else
9545           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9546         endif
9547 #endif
9548         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9549 !        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9550       endif
9551 ! Derivatives in gamma(l-1) or gamma(j-1)
9552       if (l.gt.1) then
9553 #ifdef MOMENT
9554         s1=dip(1,jj,i)*dipderg(3,kk,k)
9555 #endif
9556         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9557         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9558         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9559         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9560         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9561         vv(1)=pizda(1,1)-pizda(2,2)
9562         vv(2)=pizda(1,2)+pizda(2,1)
9563         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9564 #ifdef MOMENT
9565         if (swap) then
9566           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9567         else
9568           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9569         endif
9570 #endif
9571         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9572 !        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9573       endif
9574 ! Cartesian derivatives.
9575       if (lprn) then
9576         write (2,*) 'In eello6_graph2'
9577         do iii=1,2
9578           write (2,*) 'iii=',iii
9579           do kkk=1,5
9580             write (2,*) 'kkk=',kkk
9581             do jjj=1,2
9582               write (2,'(3(2f10.5),5x)') &
9583               ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9584             enddo
9585           enddo
9586         enddo
9587       endif
9588       do iii=1,2
9589         do kkk=1,5
9590           do lll=1,3
9591 #ifdef MOMENT
9592             if (iii.eq.1) then
9593               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9594             else
9595               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9596             endif
9597 #endif
9598             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),&
9599               auxvec(1))
9600             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9601             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),&
9602               auxvec(1))
9603             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9604             call transpose2(EUg(1,1,k),auxmat(1,1))
9605             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),&
9606               pizda(1,1))
9607             vv(1)=pizda(1,1)-pizda(2,2)
9608             vv(2)=pizda(1,2)+pizda(2,1)
9609             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9610 !d            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9611 #ifdef MOMENT
9612             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9613 #else
9614             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9615 #endif
9616             if (swap) then
9617               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9618             else
9619               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9620             endif
9621           enddo
9622         enddo
9623       enddo
9624       return
9625       end function eello6_graph2
9626 !-----------------------------------------------------------------------------
9627       real(kind=8) function eello6_graph3(i,j,k,l,jj,kk,swap)
9628 !      implicit real*8 (a-h,o-z)
9629 !      include 'DIMENSIONS'
9630 !      include 'COMMON.IOUNITS'
9631 !      include 'COMMON.CHAIN'
9632 !      include 'COMMON.DERIV'
9633 !      include 'COMMON.INTERACT'
9634 !      include 'COMMON.CONTACTS'
9635 !      include 'COMMON.TORSION'
9636 !      include 'COMMON.VAR'
9637 !      include 'COMMON.GEO'
9638       real(kind=8),dimension(2) :: vv,auxvec
9639       real(kind=8),dimension(2,2) :: pizda,auxmat
9640       logical :: swap
9641       integer :: i,j,k,l,jj,kk,iti,itj1,itk,itk1,iii,lll,kkk,itl1
9642       real(kind=8) :: s1,s2,s3,s4
9643 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9644 !                                                                              C
9645 !      Parallel       Antiparallel                                             C
9646 !                                                                              C
9647 !          o             o                                                     C
9648 !         /l\   /   \   /j\                                                    C
9649 !        /   \ /     \ /   \                                                   C
9650 !       /| o |o       o| o |\                                                  C
9651 !       j|/k\|  /      |/k\|l /                                                C
9652 !        /   \ /       /   \ /                                                 C
9653 !       /     o       /     o                                                  C
9654 !       i             i                                                        C
9655 !                                                                              C
9656 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9657 !
9658 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9659 !           energy moment and not to the cluster cumulant.
9660       iti=itortyp(itype(i,1))
9661       if (j.lt.nres-1) then
9662         itj1=itortyp(itype(j+1,1))
9663       else
9664         itj1=ntortyp+1
9665       endif
9666       itk=itortyp(itype(k,1))
9667       itk1=itortyp(itype(k+1,1))
9668       if (l.lt.nres-1) then
9669         itl1=itortyp(itype(l+1,1))
9670       else
9671         itl1=ntortyp+1
9672       endif
9673 #ifdef MOMENT
9674       s1=dip(4,jj,i)*dip(4,kk,k)
9675 #endif
9676       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
9677       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9678       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
9679       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9680       call transpose2(EE(1,1,itk),auxmat(1,1))
9681       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9682       vv(1)=pizda(1,1)+pizda(2,2)
9683       vv(2)=pizda(2,1)-pizda(1,2)
9684       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9685 !d      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9686 !d     & "sum",-(s2+s3+s4)
9687 #ifdef MOMENT
9688       eello6_graph3=-(s1+s2+s3+s4)
9689 #else
9690       eello6_graph3=-(s2+s3+s4)
9691 #endif
9692 !      eello6_graph3=-s4
9693 ! Derivatives in gamma(k-1)
9694       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
9695       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9696       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9697       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9698 ! Derivatives in gamma(l-1)
9699       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
9700       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9701       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9702       vv(1)=pizda(1,1)+pizda(2,2)
9703       vv(2)=pizda(2,1)-pizda(1,2)
9704       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9705       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9706 ! Cartesian derivatives.
9707       do iii=1,2
9708         do kkk=1,5
9709           do lll=1,3
9710 #ifdef MOMENT
9711             if (iii.eq.1) then
9712               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9713             else
9714               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9715             endif
9716 #endif
9717             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),&
9718               auxvec(1))
9719             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
9720             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),&
9721               auxvec(1))
9722             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
9723             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),&
9724               pizda(1,1))
9725             vv(1)=pizda(1,1)+pizda(2,2)
9726             vv(2)=pizda(2,1)-pizda(1,2)
9727             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9728 #ifdef MOMENT
9729             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9730 #else
9731             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9732 #endif
9733             if (swap) then
9734               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9735             else
9736               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9737             endif
9738 !            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9739           enddo
9740         enddo
9741       enddo
9742       return
9743       end function eello6_graph3
9744 !-----------------------------------------------------------------------------
9745       real(kind=8) function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9746 !      implicit real*8 (a-h,o-z)
9747 !      include 'DIMENSIONS'
9748 !      include 'COMMON.IOUNITS'
9749 !      include 'COMMON.CHAIN'
9750 !      include 'COMMON.DERIV'
9751 !      include 'COMMON.INTERACT'
9752 !      include 'COMMON.CONTACTS'
9753 !      include 'COMMON.TORSION'
9754 !      include 'COMMON.VAR'
9755 !      include 'COMMON.GEO'
9756 !      include 'COMMON.FFIELD'
9757       real(kind=8),dimension(2) :: vv,auxvec,auxvec1
9758       real(kind=8),dimension(2,2) :: pizda,auxmat,auxmat1
9759       logical :: swap
9760       integer :: i,j,k,l,jj,kk,imat,iti,itj,itj1,itk,itk1,itl,itl1,&
9761               iii,kkk,lll
9762       real(kind=8) :: s1,s2,s3,s4
9763 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9764 !                                                                              C
9765 !      Parallel       Antiparallel                                             C
9766 !                                                                              C
9767 !          o             o                                                     C
9768 !         /l\   /   \   /j\                                                    C
9769 !        /   \ /     \ /   \                                                   C
9770 !       /| o |o       o| o |\                                                  C
9771 !     \ j|/k\|      \  |/k\|l                                                  C
9772 !      \ /   \       \ /   \                                                   C
9773 !       o     \       o     \                                                  C
9774 !       i             i                                                        C
9775 !                                                                              C
9776 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9777 !
9778 ! 4/7/01 AL Component s1 was removed, because it pertains to the respective
9779 !           energy moment and not to the cluster cumulant.
9780 !d      write (2,*) 'eello_graph4: wturn6',wturn6
9781       iti=itortyp(itype(i,1))
9782       itj=itortyp(itype(j,1))
9783       if (j.lt.nres-1) then
9784         itj1=itortyp(itype(j+1,1))
9785       else
9786         itj1=ntortyp+1
9787       endif
9788       itk=itortyp(itype(k,1))
9789       if (k.lt.nres-1) then
9790         itk1=itortyp(itype(k+1,1))
9791       else
9792         itk1=ntortyp+1
9793       endif
9794       itl=itortyp(itype(l,1))
9795       if (l.lt.nres-1) then
9796         itl1=itortyp(itype(l+1,1))
9797       else
9798         itl1=ntortyp+1
9799       endif
9800 !d      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9801 !d      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9802 !d     & ' itl',itl,' itl1',itl1
9803 #ifdef MOMENT
9804       if (imat.eq.1) then
9805         s1=dip(3,jj,i)*dip(3,kk,k)
9806       else
9807         s1=dip(2,jj,j)*dip(2,kk,l)
9808       endif
9809 #endif
9810       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9811       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9812       if (j.eq.l+1) then
9813         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
9814         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9815       else
9816         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
9817         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9818       endif
9819       call transpose2(EUg(1,1,k),auxmat(1,1))
9820       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9821       vv(1)=pizda(1,1)-pizda(2,2)
9822       vv(2)=pizda(2,1)+pizda(1,2)
9823       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9824 !d      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9825 #ifdef MOMENT
9826       eello6_graph4=-(s1+s2+s3+s4)
9827 #else
9828       eello6_graph4=-(s2+s3+s4)
9829 #endif
9830 ! Derivatives in gamma(i-1)
9831       if (i.gt.1) then
9832 #ifdef MOMENT
9833         if (imat.eq.1) then
9834           s1=dipderg(2,jj,i)*dip(3,kk,k)
9835         else
9836           s1=dipderg(4,jj,j)*dip(2,kk,l)
9837         endif
9838 #endif
9839         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9840         if (j.eq.l+1) then
9841           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
9842           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9843         else
9844           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
9845           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9846         endif
9847         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9848         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9849 !d          write (2,*) 'turn6 derivatives'
9850 #ifdef MOMENT
9851           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9852 #else
9853           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9854 #endif
9855         else
9856 #ifdef MOMENT
9857           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9858 #else
9859           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9860 #endif
9861         endif
9862       endif
9863 ! Derivatives in gamma(k-1)
9864 #ifdef MOMENT
9865       if (imat.eq.1) then
9866         s1=dip(3,jj,i)*dipderg(2,kk,k)
9867       else
9868         s1=dip(2,jj,j)*dipderg(4,kk,l)
9869       endif
9870 #endif
9871       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9872       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9873       if (j.eq.l+1) then
9874         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
9875         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
9876       else
9877         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
9878         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
9879       endif
9880       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9881       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9882       vv(1)=pizda(1,1)-pizda(2,2)
9883       vv(2)=pizda(2,1)+pizda(1,2)
9884       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9885       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9886 #ifdef MOMENT
9887         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9888 #else
9889         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9890 #endif
9891       else
9892 #ifdef MOMENT
9893         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9894 #else
9895         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9896 #endif
9897       endif
9898 ! Derivatives in gamma(j-1) or gamma(l-1)
9899       if (l.eq.j+1 .and. l.gt.1) then
9900         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9901         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9902         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9903         vv(1)=pizda(1,1)-pizda(2,2)
9904         vv(2)=pizda(2,1)+pizda(1,2)
9905         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9906         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9907       else if (j.gt.1) then
9908         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9909         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9910         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9911         vv(1)=pizda(1,1)-pizda(2,2)
9912         vv(2)=pizda(2,1)+pizda(1,2)
9913         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9914         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9915           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9916         else
9917           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9918         endif
9919       endif
9920 ! Cartesian derivatives.
9921       do iii=1,2
9922         do kkk=1,5
9923           do lll=1,3
9924 #ifdef MOMENT
9925             if (iii.eq.1) then
9926               if (imat.eq.1) then
9927                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9928               else
9929                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9930               endif
9931             else
9932               if (imat.eq.1) then
9933                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9934               else
9935                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9936               endif
9937             endif
9938 #endif
9939             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),&
9940               auxvec(1))
9941             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9942             if (j.eq.l+1) then
9943               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9944                 b1(1,itj1),auxvec(1))
9945               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
9946             else
9947               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),&
9948                 b1(1,itl1),auxvec(1))
9949               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
9950             endif
9951             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),&
9952               pizda(1,1))
9953             vv(1)=pizda(1,1)-pizda(2,2)
9954             vv(2)=pizda(2,1)+pizda(1,2)
9955             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9956             if (swap) then
9957               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9958 #ifdef MOMENT
9959                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9960                    -(s1+s2+s4)
9961 #else
9962                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii) &
9963                    -(s2+s4)
9964 #endif
9965                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9966               else
9967 #ifdef MOMENT
9968                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9969 #else
9970                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9971 #endif
9972                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9973               endif
9974             else
9975 #ifdef MOMENT
9976               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9977 #else
9978               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9979 #endif
9980               if (l.eq.j+1) then
9981                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9982               else
9983                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9984               endif
9985             endif
9986           enddo
9987         enddo
9988       enddo
9989       return
9990       end function eello6_graph4
9991 !-----------------------------------------------------------------------------
9992       real(kind=8) function eello_turn6(i,jj,kk)
9993 !      implicit real*8 (a-h,o-z)
9994 !      include 'DIMENSIONS'
9995 !      include 'COMMON.IOUNITS'
9996 !      include 'COMMON.CHAIN'
9997 !      include 'COMMON.DERIV'
9998 !      include 'COMMON.INTERACT'
9999 !      include 'COMMON.CONTACTS'
10000 !      include 'COMMON.TORSION'
10001 !      include 'COMMON.VAR'
10002 !      include 'COMMON.GEO'
10003       real(kind=8),dimension(2) :: vtemp1,vtemp2,vtemp3,vtemp4,gvec
10004       real(kind=8),dimension(2,2) :: atemp,auxmat,achuj_temp,gtemp
10005       real(kind=8),dimension(3) :: ggg1,ggg2
10006       real(kind=8),dimension(2) :: vtemp1d,vtemp2d,vtemp3d,vtemp4d,gvecd
10007       real(kind=8),dimension(2,2) :: atempd,auxmatd,achuj_tempd,gtempd
10008 ! 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10009 !           the respective energy moment and not to the cluster cumulant.
10010 !el local variables
10011       integer :: i,jj,kk,j,k,l,iti,itk,itk1,itl,itj,iii,kkk,lll
10012       integer :: j1,j2,l1,l2,ll
10013       real(kind=8) :: s1,s2,s8,s13,s12,eello6_5,eel_turn6
10014       real(kind=8) :: s1d,s8d,s12d,s2d,gturn6ij,gturn6kl
10015       s1=0.0d0
10016       s8=0.0d0
10017       s13=0.0d0
10018 !
10019       eello_turn6=0.0d0
10020       j=i+4
10021       k=i+1
10022       l=i+3
10023       iti=itortyp(itype(i,1))
10024       itk=itortyp(itype(k,1))
10025       itk1=itortyp(itype(k+1,1))
10026       itl=itortyp(itype(l,1))
10027       itj=itortyp(itype(j,1))
10028 !d      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10029 !d      write (2,*) 'i',i,' k',k,' j',j,' l',l
10030 !d      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10031 !d        eello6=0.0d0
10032 !d        return
10033 !d      endif
10034 !d      write (iout,*)
10035 !d     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10036 !d     &   ' and',k,l
10037 !d      call checkint_turn6(i,jj,kk,eel_turn6_num)
10038       do iii=1,2
10039         do kkk=1,5
10040           do lll=1,3
10041             derx_turn(lll,kkk,iii)=0.0d0
10042           enddo
10043         enddo
10044       enddo
10045 !d      eij=1.0d0
10046 !d      ekl=1.0d0
10047 !d      ekont=1.0d0
10048       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10049 !d      eello6_5=0.0d0
10050 !d      write (2,*) 'eello6_5',eello6_5
10051 #ifdef MOMENT
10052       call transpose2(AEA(1,1,1),auxmat(1,1))
10053       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10054       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
10055       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10056 #endif
10057       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10058       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10059       s2 = scalar2(b1(1,itk),vtemp1(1))
10060 #ifdef MOMENT
10061       call transpose2(AEA(1,1,2),atemp(1,1))
10062       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10063       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
10064       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10065 #endif
10066       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10067       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10068       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10069 #ifdef MOMENT
10070       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10071       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10072       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10073       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10074       ss13 = scalar2(b1(1,itk),vtemp4(1))
10075       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10076 #endif
10077 !      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10078 !      s1=0.0d0
10079 !      s2=0.0d0
10080 !      s8=0.0d0
10081 !      s12=0.0d0
10082 !      s13=0.0d0
10083       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10084 ! Derivatives in gamma(i+2)
10085       s1d =0.0d0
10086       s8d =0.0d0
10087 #ifdef MOMENT
10088       call transpose2(AEA(1,1,1),auxmatd(1,1))
10089       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10090       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10091       call transpose2(AEAderg(1,1,2),atempd(1,1))
10092       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10093       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10094 #endif
10095       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10096       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10097       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10098 !      s1d=0.0d0
10099 !      s2d=0.0d0
10100 !      s8d=0.0d0
10101 !      s12d=0.0d0
10102 !      s13d=0.0d0
10103       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10104 ! Derivatives in gamma(i+3)
10105 #ifdef MOMENT
10106       call transpose2(AEA(1,1,1),auxmatd(1,1))
10107       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10108       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
10109       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10110 #endif
10111       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
10112       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10113       s2d = scalar2(b1(1,itk),vtemp1d(1))
10114 #ifdef MOMENT
10115       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
10116       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
10117 #endif
10118       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10119 #ifdef MOMENT
10120       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10121       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10122       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10123 #endif
10124 !      s1d=0.0d0
10125 !      s2d=0.0d0
10126 !      s8d=0.0d0
10127 !      s12d=0.0d0
10128 !      s13d=0.0d0
10129 #ifdef MOMENT
10130       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10131                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10132 #else
10133       gel_loc_turn6(i+1)=gel_loc_turn6(i+1) &
10134                     -0.5d0*ekont*(s2d+s12d)
10135 #endif
10136 ! Derivatives in gamma(i+4)
10137       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10138       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10139       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10140 #ifdef MOMENT
10141       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10142       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10143       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10144 #endif
10145 !      s1d=0.0d0
10146 !      s2d=0.0d0
10147 !      s8d=0.0d0
10148 !      s12d=0.0d0
10149 !      s13d=0.0d0
10150 #ifdef MOMENT
10151       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10152 #else
10153       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10154 #endif
10155 ! Derivatives in gamma(i+5)
10156 #ifdef MOMENT
10157       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10158       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10159       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10160 #endif
10161       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
10162       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10163       s2d = scalar2(b1(1,itk),vtemp1d(1))
10164 #ifdef MOMENT
10165       call transpose2(AEA(1,1,2),atempd(1,1))
10166       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10167       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
10168 #endif
10169       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10170       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10171 #ifdef MOMENT
10172       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10173       ss13d = scalar2(b1(1,itk),vtemp4d(1))
10174       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10175 #endif
10176 !      s1d=0.0d0
10177 !      s2d=0.0d0
10178 !      s8d=0.0d0
10179 !      s12d=0.0d0
10180 !      s13d=0.0d0
10181 #ifdef MOMENT
10182       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10183                     -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10184 #else
10185       gel_loc_turn6(i+3)=gel_loc_turn6(i+3) &
10186                     -0.5d0*ekont*(s2d+s12d)
10187 #endif
10188 ! Cartesian derivatives
10189       do iii=1,2
10190         do kkk=1,5
10191           do lll=1,3
10192 #ifdef MOMENT
10193             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10194             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10195             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10196 #endif
10197             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
10198             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),&
10199                 vtemp1d(1))
10200             s2d = scalar2(b1(1,itk),vtemp1d(1))
10201 #ifdef MOMENT
10202             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10203             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10204             s8d = -(atempd(1,1)+atempd(2,2))* &
10205                  scalar2(cc(1,1,itl),vtemp2(1))
10206 #endif
10207             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),&
10208                  auxmatd(1,1))
10209             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10210             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10211 !      s1d=0.0d0
10212 !      s2d=0.0d0
10213 !      s8d=0.0d0
10214 !      s12d=0.0d0
10215 !      s13d=0.0d0
10216 #ifdef MOMENT
10217             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10218               - 0.5d0*(s1d+s2d)
10219 #else
10220             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii) &
10221               - 0.5d0*s2d
10222 #endif
10223 #ifdef MOMENT
10224             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10225               - 0.5d0*(s8d+s12d)
10226 #else
10227             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii) &
10228               - 0.5d0*s12d
10229 #endif
10230           enddo
10231         enddo
10232       enddo
10233 #ifdef MOMENT
10234       do kkk=1,5
10235         do lll=1,3
10236           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),&
10237             achuj_tempd(1,1))
10238           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10239           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10240           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10241           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10242           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),&
10243             vtemp4d(1))
10244           ss13d = scalar2(b1(1,itk),vtemp4d(1))
10245           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10246           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10247         enddo
10248       enddo
10249 #endif
10250 !d      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10251 !d     &  16*eel_turn6_num
10252 !d      goto 1112
10253       if (j.lt.nres-1) then
10254         j1=j+1
10255         j2=j-1
10256       else
10257         j1=j-1
10258         j2=j-2
10259       endif
10260       if (l.lt.nres-1) then
10261         l1=l+1
10262         l2=l-1
10263       else
10264         l1=l-1
10265         l2=l-2
10266       endif
10267       do ll=1,3
10268 !grad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10269 !grad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10270 !grad        ghalf=0.5d0*ggg1(ll)
10271 !d        ghalf=0.0d0
10272         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10273         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10274         gcorr6_turn(ll,i)=gcorr6_turn(ll,i) & !+ghalf
10275           +ekont*derx_turn(ll,2,1)
10276         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10277         gcorr6_turn(ll,j)=gcorr6_turn(ll,j) & !+ghalf
10278           +ekont*derx_turn(ll,4,1)
10279         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10280         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10281         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10282 !grad        ghalf=0.5d0*ggg2(ll)
10283 !d        ghalf=0.0d0
10284         gcorr6_turn(ll,k)=gcorr6_turn(ll,k) & !+ghalf
10285           +ekont*derx_turn(ll,2,2)
10286         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10287         gcorr6_turn(ll,l)=gcorr6_turn(ll,l) & !+ghalf
10288           +ekont*derx_turn(ll,4,2)
10289         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10290         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10291         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10292       enddo
10293 !d      goto 1112
10294 !grad      do m=i+1,j-1
10295 !grad        do ll=1,3
10296 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10297 !grad        enddo
10298 !grad      enddo
10299 !grad      do m=k+1,l-1
10300 !grad        do ll=1,3
10301 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10302 !grad        enddo
10303 !grad      enddo
10304 !grad1112  continue
10305 !grad      do m=i+2,j2
10306 !grad        do ll=1,3
10307 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10308 !grad        enddo
10309 !grad      enddo
10310 !grad      do m=k+2,l2
10311 !grad        do ll=1,3
10312 !grad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10313 !grad        enddo
10314 !grad      enddo
10315 !d      do iii=1,nres-3
10316 !d        write (2,*) iii,g_corr6_loc(iii)
10317 !d      enddo
10318       eello_turn6=ekont*eel_turn6
10319 !d      write (2,*) 'ekont',ekont
10320 !d      write (2,*) 'eel_turn6',ekont*eel_turn6
10321       return
10322       end function eello_turn6
10323 !-----------------------------------------------------------------------------
10324       subroutine MATVEC2(A1,V1,V2)
10325 !DIR$ INLINEALWAYS MATVEC2
10326 #ifndef OSF
10327 !DEC$ ATTRIBUTES FORCEINLINE::MATVEC2
10328 #endif
10329 !      implicit real*8 (a-h,o-z)
10330 !      include 'DIMENSIONS'
10331       real(kind=8),dimension(2) :: V1,V2
10332       real(kind=8),dimension(2,2) :: A1
10333       real(kind=8) :: vaux1,vaux2
10334 !      DO 1 I=1,2
10335 !        VI=0.0
10336 !        DO 3 K=1,2
10337 !    3     VI=VI+A1(I,K)*V1(K)
10338 !        Vaux(I)=VI
10339 !    1 CONTINUE
10340
10341       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10342       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10343
10344       v2(1)=vaux1
10345       v2(2)=vaux2
10346       end subroutine MATVEC2
10347 !-----------------------------------------------------------------------------
10348       subroutine MATMAT2(A1,A2,A3)
10349 #ifndef OSF
10350 !DEC$ ATTRIBUTES FORCEINLINE::MATMAT2
10351 #endif
10352 !      implicit real*8 (a-h,o-z)
10353 !      include 'DIMENSIONS'
10354       real(kind=8),dimension(2,2) :: A1,A2,A3
10355       real(kind=8) :: ai3_11,ai3_12,ai3_21,ai3_22
10356 !      DIMENSION AI3(2,2)
10357 !        DO  J=1,2
10358 !          A3IJ=0.0
10359 !          DO K=1,2
10360 !           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10361 !          enddo
10362 !          A3(I,J)=A3IJ
10363 !       enddo
10364 !      enddo
10365
10366       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10367       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10368       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10369       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10370
10371       A3(1,1)=AI3_11
10372       A3(2,1)=AI3_21
10373       A3(1,2)=AI3_12
10374       A3(2,2)=AI3_22
10375       end subroutine MATMAT2
10376 !-----------------------------------------------------------------------------
10377       real(kind=8) function scalar2(u,v)
10378 !DIR$ INLINEALWAYS scalar2
10379       implicit none
10380       real(kind=8),dimension(2) :: u,v
10381       real(kind=8) :: sc
10382       integer :: i
10383       scalar2=u(1)*v(1)+u(2)*v(2)
10384       return
10385       end function scalar2
10386 !-----------------------------------------------------------------------------
10387       subroutine transpose2(a,at)
10388 !DIR$ INLINEALWAYS transpose2
10389 #ifndef OSF
10390 !DEC$ ATTRIBUTES FORCEINLINE::transpose2
10391 #endif
10392       implicit none
10393       real(kind=8),dimension(2,2) :: a,at
10394       at(1,1)=a(1,1)
10395       at(1,2)=a(2,1)
10396       at(2,1)=a(1,2)
10397       at(2,2)=a(2,2)
10398       return
10399       end subroutine transpose2
10400 !-----------------------------------------------------------------------------
10401       subroutine transpose(n,a,at)
10402       implicit none
10403       integer :: n,i,j
10404       real(kind=8),dimension(n,n) :: a,at
10405       do i=1,n
10406         do j=1,n
10407           at(j,i)=a(i,j)
10408         enddo
10409       enddo
10410       return
10411       end subroutine transpose
10412 !-----------------------------------------------------------------------------
10413       subroutine prodmat3(a1,a2,kk,transp,prod)
10414 !DIR$ INLINEALWAYS prodmat3
10415 #ifndef OSF
10416 !DEC$ ATTRIBUTES FORCEINLINE::prodmat3
10417 #endif
10418       implicit none
10419       integer :: i,j
10420       real(kind=8),dimension(2,2) :: a1,a2,a2t,kk,prod
10421       logical :: transp
10422 !rc      double precision auxmat(2,2),prod_(2,2)
10423
10424       if (transp) then
10425 !rc        call transpose2(kk(1,1),auxmat(1,1))
10426 !rc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10427 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10428
10429            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1) &
10430        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10431            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2) &
10432        +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10433            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1) &
10434        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10435            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2) &
10436        +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10437
10438       else
10439 !rc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10440 !rc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10441
10442            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1) &
10443         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10444            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2) &
10445         +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10446            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1) &
10447         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10448            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2) &
10449         +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10450
10451       endif
10452 !      call transpose2(a2(1,1),a2t(1,1))
10453
10454 !rc      print *,transp
10455 !rc      print *,((prod_(i,j),i=1,2),j=1,2)
10456 !rc      print *,((prod(i,j),i=1,2),j=1,2)
10457
10458       return
10459       end subroutine prodmat3
10460 !-----------------------------------------------------------------------------
10461 ! energy_p_new_barrier.F
10462 !-----------------------------------------------------------------------------
10463       subroutine sum_gradient
10464 !      implicit real*8 (a-h,o-z)
10465       use io_base, only: pdbout
10466 !      include 'DIMENSIONS'
10467 #ifndef ISNAN
10468       external proc_proc
10469 #ifdef WINPGI
10470 !MS$ATTRIBUTES C ::  proc_proc
10471 #endif
10472 #endif
10473 #ifdef MPI
10474       include 'mpif.h'
10475 #endif
10476       real(kind=8),dimension(3,-1:nres) :: gradbufc,gradbufx,gradbufc_sum,&
10477                    gloc_scbuf !(3,maxres)
10478
10479       real(kind=8),dimension(4*nres) :: glocbuf !(4*maxres)
10480 !#endif
10481 !el local variables
10482       integer :: i,j,k,ierror,ierr
10483       real(kind=8) :: gvdwc_norm,gvdwc_scp_norm,gelc_norm,gvdwpp_norm,&
10484                    gradb_norm,ghpbc_norm,gradcorr_norm,gel_loc_norm,&
10485                    gcorr3_turn_norm,gcorr4_turn_norm,gradcorr5_norm,&
10486                    gradcorr6_norm,gcorr6_turn_norm,gsccorr_norm,&
10487                    gscloc_norm,gvdwx_norm,gradx_scp_norm,ghpbx_norm,&
10488                    gradxorr_norm,gsccorrx_norm,gsclocx_norm,gcorr6_max,&
10489                    gsccorr_max,gsccorrx_max,time00
10490
10491 !      include 'COMMON.SETUP'
10492 !      include 'COMMON.IOUNITS'
10493 !      include 'COMMON.FFIELD'
10494 !      include 'COMMON.DERIV'
10495 !      include 'COMMON.INTERACT'
10496 !      include 'COMMON.SBRIDGE'
10497 !      include 'COMMON.CHAIN'
10498 !      include 'COMMON.VAR'
10499 !      include 'COMMON.CONTROL'
10500 !      include 'COMMON.TIME1'
10501 !      include 'COMMON.MAXGRAD'
10502 !      include 'COMMON.SCCOR'
10503 #ifdef TIMING
10504       time01=MPI_Wtime()
10505 #endif
10506 #ifdef DEBUG
10507       write (iout,*) "sum_gradient gvdwc, gvdwx"
10508       do i=1,nres
10509         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10510          i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
10511       enddo
10512       call flush(iout)
10513 #endif
10514 #ifdef MPI
10515         gradbufc=0.0d0
10516         gradbufx=0.0d0
10517         gradbufc_sum=0.0d0
10518         gloc_scbuf=0.0d0
10519         glocbuf=0.0d0
10520 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
10521         if (nfgtasks.gt.1 .and. fg_rank.eq.0) &
10522           call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
10523 #endif
10524 !
10525 ! 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
10526 !            in virtual-bond-vector coordinates
10527 !
10528 #ifdef DEBUG
10529 !      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
10530 !      do i=1,nres-1
10531 !        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
10532 !     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
10533 !      enddo
10534 !      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
10535 !      do i=1,nres-1
10536 !        write (iout,'(i5,3f10.5,2x,f10.5)')
10537 !     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
10538 !      enddo
10539       write (iout,*) "gvdwc gvdwc_scp gvdwc_scpp"
10540       do i=1,nres
10541         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10542          i,(gvdwc(j,i),j=1,3),(gvdwc_scp(j,i),j=1,3),&
10543          (gvdwc_scpp(j,i),j=1,3)
10544       enddo
10545       write (iout,*) "gelc_long gvdwpp gel_loc_long"
10546       do i=1,nres
10547         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)') &
10548          i,(gelc_long(j,i),j=1,3),(gvdwpp(j,i),j=1,3),&
10549          (gelc_loc_long(j,i),j=1,3)
10550       enddo
10551       call flush(iout)
10552 #endif
10553 #ifdef SPLITELE
10554       do i=0,nct
10555         do j=1,3
10556           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10557                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10558                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10559                       wel_loc*gel_loc_long(j,i)+ &
10560                       wcorr*gradcorr_long(j,i)+ &
10561                       wcorr5*gradcorr5_long(j,i)+ &
10562                       wcorr6*gradcorr6_long(j,i)+ &
10563                       wturn6*gcorr6_turn_long(j,i)+ &
10564                       wstrain*ghpbc(j,i) &
10565                      +wliptran*gliptranc(j,i) &
10566                      +gradafm(j,i) &
10567                      +welec*gshieldc(j,i) &
10568                      +wcorr*gshieldc_ec(j,i) &
10569                      +wturn3*gshieldc_t3(j,i)&
10570                      +wturn4*gshieldc_t4(j,i)&
10571                      +wel_loc*gshieldc_ll(j,i)&
10572                      +wtube*gg_tube(j,i) &
10573                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10574                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10575                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10576                      wcorr_nucl*gradcorr_nucl(j,i)&
10577                      +wcorr3_nucl*gradcorr3_nucl(j,i)+&
10578                      wcatprot* gradpepcat(j,i)+ &
10579                      wcatcat*gradcatcat(j,i)+   &
10580                      wscbase*gvdwc_scbase(j,i)+ &
10581                      wpepbase*gvdwc_pepbase(j,i)+&
10582                      wscpho*gvdwc_scpho(j,i)+   &
10583                      wpeppho*gvdwc_peppho(j,i)
10584
10585
10586
10587
10588
10589         enddo
10590       enddo
10591 #else
10592       do i=0,nct
10593         do j=1,3
10594           gradbufc(j,i)=wsc*gvdwc(j,i)+ &
10595                       wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+ &
10596                       welec*gelc_long(j,i)+ &
10597                       wbond*gradb(j,i)+ &
10598                       wel_loc*gel_loc_long(j,i)+ &
10599                       wcorr*gradcorr_long(j,i)+ &
10600                       wcorr5*gradcorr5_long(j,i)+ &
10601                       wcorr6*gradcorr6_long(j,i)+ &
10602                       wturn6*gcorr6_turn_long(j,i)+ &
10603                       wstrain*ghpbc(j,i) &
10604                      +wliptran*gliptranc(j,i) &
10605                      +gradafm(j,i) &
10606                      +welec*gshieldc(j,i)&
10607                      +wcorr*gshieldc_ec(j,i) &
10608                      +wturn4*gshieldc_t4(j,i) &
10609                      +wel_loc*gshieldc_ll(j,i)&
10610                      +wtube*gg_tube(j,i) &
10611                      +wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)+ &
10612                      wvdwpsb*(gvdwpsb(j,i)+gvdwpsb1(j,i))+ &
10613                      wvdwsb*gvdwsbc(j,i)+welsb*gelsbc(j,i)+ &
10614                      wcorr_nucl*gradcorr_nucl(j,i) &
10615                      +wcorr3_nucl*gradcorr3_nucl(j,i) +&
10616                      wcatprot* gradpepcat(j,i)+ &
10617                      wcatcat*gradcatcat(j,i)+   &
10618                      wscbase*gvdwc_scbase(j,i)  &
10619                      wpepbase*gvdwc_pepbase(j,i)+&
10620                      wscpho*gvdwc_scpho(j,i)+&
10621                      wpeppho*gvdwc_peppho(j,i)
10622
10623
10624         enddo
10625       enddo
10626 #endif
10627 #ifdef MPI
10628       if (nfgtasks.gt.1) then
10629       time00=MPI_Wtime()
10630 #ifdef DEBUG
10631       write (iout,*) "gradbufc before allreduce"
10632       do i=1,nres
10633         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10634       enddo
10635       call flush(iout)
10636 #endif
10637       do i=0,nres
10638         do j=1,3
10639           gradbufc_sum(j,i)=gradbufc(j,i)
10640         enddo
10641       enddo
10642 !      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
10643 !     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
10644 !      time_reduce=time_reduce+MPI_Wtime()-time00
10645 #ifdef DEBUG
10646 !      write (iout,*) "gradbufc_sum after allreduce"
10647 !      do i=1,nres
10648 !        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
10649 !      enddo
10650 !      call flush(iout)
10651 #endif
10652 #ifdef TIMING
10653 !      time_allreduce=time_allreduce+MPI_Wtime()-time00
10654 #endif
10655       do i=0,nres
10656         do k=1,3
10657           gradbufc(k,i)=0.0d0
10658         enddo
10659       enddo
10660 #ifdef DEBUG
10661       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
10662       write (iout,*) (i," jgrad_start",jgrad_start(i),&
10663                         " jgrad_end  ",jgrad_end(i),&
10664                         i=igrad_start,igrad_end)
10665 #endif
10666 !
10667 ! Obsolete and inefficient code; we can make the effort O(n) and, therefore,
10668 ! do not parallelize this part.
10669 !
10670 !      do i=igrad_start,igrad_end
10671 !        do j=jgrad_start(i),jgrad_end(i)
10672 !          do k=1,3
10673 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
10674 !          enddo
10675 !        enddo
10676 !      enddo
10677       do j=1,3
10678         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10679       enddo
10680       do i=nres-2,-1,-1
10681         do j=1,3
10682           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10683         enddo
10684       enddo
10685 #ifdef DEBUG
10686       write (iout,*) "gradbufc after summing"
10687       do i=1,nres
10688         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10689       enddo
10690       call flush(iout)
10691 #endif
10692       else
10693 #endif
10694 !el#define DEBUG
10695 #ifdef DEBUG
10696       write (iout,*) "gradbufc"
10697       do i=1,nres
10698         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10699       enddo
10700       call flush(iout)
10701 #endif
10702 !el#undef DEBUG
10703       do i=-1,nres
10704         do j=1,3
10705           gradbufc_sum(j,i)=gradbufc(j,i)
10706           gradbufc(j,i)=0.0d0
10707         enddo
10708       enddo
10709       do j=1,3
10710         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
10711       enddo
10712       do i=nres-2,-1,-1
10713         do j=1,3
10714           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
10715         enddo
10716       enddo
10717 !      do i=nnt,nres-1
10718 !        do k=1,3
10719 !          gradbufc(k,i)=0.0d0
10720 !        enddo
10721 !        do j=i+1,nres
10722 !          do k=1,3
10723 !            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
10724 !          enddo
10725 !        enddo
10726 !      enddo
10727 !el#define DEBUG
10728 #ifdef DEBUG
10729       write (iout,*) "gradbufc after summing"
10730       do i=1,nres
10731         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
10732       enddo
10733       call flush(iout)
10734 #endif
10735 !el#undef DEBUG
10736 #ifdef MPI
10737       endif
10738 #endif
10739       do k=1,3
10740         gradbufc(k,nres)=0.0d0
10741       enddo
10742 !el----------------
10743 !el      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
10744 !el      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
10745 !el-----------------
10746       do i=-1,nct
10747         do j=1,3
10748 #ifdef SPLITELE
10749           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10750                       wel_loc*gel_loc(j,i)+ &
10751                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10752                       welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+ &
10753                       wel_loc*gel_loc_long(j,i)+ &
10754                       wcorr*gradcorr_long(j,i)+ &
10755                       wcorr5*gradcorr5_long(j,i)+ &
10756                       wcorr6*gradcorr6_long(j,i)+ &
10757                       wturn6*gcorr6_turn_long(j,i))+ &
10758                       wbond*gradb(j,i)+ &
10759                       wcorr*gradcorr(j,i)+ &
10760                       wturn3*gcorr3_turn(j,i)+ &
10761                       wturn4*gcorr4_turn(j,i)+ &
10762                       wcorr5*gradcorr5(j,i)+ &
10763                       wcorr6*gradcorr6(j,i)+ &
10764                       wturn6*gcorr6_turn(j,i)+ &
10765                       wsccor*gsccorc(j,i) &
10766                      +wscloc*gscloc(j,i)  &
10767                      +wliptran*gliptranc(j,i) &
10768                      +gradafm(j,i) &
10769                      +welec*gshieldc(j,i) &
10770                      +welec*gshieldc_loc(j,i) &
10771                      +wcorr*gshieldc_ec(j,i) &
10772                      +wcorr*gshieldc_loc_ec(j,i) &
10773                      +wturn3*gshieldc_t3(j,i) &
10774                      +wturn3*gshieldc_loc_t3(j,i) &
10775                      +wturn4*gshieldc_t4(j,i) &
10776                      +wturn4*gshieldc_loc_t4(j,i) &
10777                      +wel_loc*gshieldc_ll(j,i) &
10778                      +wel_loc*gshieldc_loc_ll(j,i) &
10779                      +wtube*gg_tube(j,i) &
10780                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10781                      +wvdwpsb*gvdwpsb1(j,i))&
10782                      +wbond_nucl*gradb_nucl(j,i)+wsbloc*gsbloc(j,i)
10783 !                      if (i.eq.21) then
10784 !                      print *,"in sum",gradc(j,i,icg),wturn4*gcorr4_turn(j,i),&
10785 !                      wturn4*gshieldc_t4(j,i), &
10786 !                     wturn4*gshieldc_loc_t4(j,i)
10787 !                       endif
10788 !                 if ((i.le.2).and.(i.ge.1))
10789 !                       print *,gradc(j,i,icg),&
10790 !                      gradbufc(j,i),welec*gelc(j,i), &
10791 !                      wel_loc*gel_loc(j,i), &
10792 !                      wscp*gvdwc_scpp(j,i), &
10793 !                      welec*gelc_long(j,i),wvdwpp*gvdwpp(j,i), &
10794 !                      wel_loc*gel_loc_long(j,i), &
10795 !                      wcorr*gradcorr_long(j,i), &
10796 !                      wcorr5*gradcorr5_long(j,i), &
10797 !                      wcorr6*gradcorr6_long(j,i), &
10798 !                      wturn6*gcorr6_turn_long(j,i), &
10799 !                      wbond*gradb(j,i), &
10800 !                      wcorr*gradcorr(j,i), &
10801 !                      wturn3*gcorr3_turn(j,i), &
10802 !                      wturn4*gcorr4_turn(j,i), &
10803 !                      wcorr5*gradcorr5(j,i), &
10804 !                      wcorr6*gradcorr6(j,i), &
10805 !                      wturn6*gcorr6_turn(j,i), &
10806 !                      wsccor*gsccorc(j,i) &
10807 !                     ,wscloc*gscloc(j,i)  &
10808 !                     ,wliptran*gliptranc(j,i) &
10809 !                    ,gradafm(j,i) &
10810 !                     ,welec*gshieldc(j,i) &
10811 !                     ,welec*gshieldc_loc(j,i) &
10812 !                     ,wcorr*gshieldc_ec(j,i) &
10813 !                     ,wcorr*gshieldc_loc_ec(j,i) &
10814 !                     ,wturn3*gshieldc_t3(j,i) &
10815 !                     ,wturn3*gshieldc_loc_t3(j,i) &
10816 !                     ,wturn4*gshieldc_t4(j,i) &
10817 !                     ,wturn4*gshieldc_loc_t4(j,i) &
10818 !                     ,wel_loc*gshieldc_ll(j,i) &
10819 !                     ,wel_loc*gshieldc_loc_ll(j,i) &
10820 !                     ,wtube*gg_tube(j,i) &
10821 !                     ,wbond_nucl*gradb_nucl(j,i) &
10822 !                     ,wvdwpp_nucl*gvdwpp_nucl(j,i),welpp*gelpp(j,i),&
10823 !                     wvdwpsb*gvdwpsb1(j,i)&
10824 !                     ,wbond_nucl*gradb_nucl(j,i),wsbloc*gsbloc(j,i)
10825 !
10826
10827 #else
10828           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+ &
10829                       wel_loc*gel_loc(j,i)+ &
10830                       0.5d0*(wscp*gvdwc_scpp(j,i)+ &
10831                       welec*gelc_long(j,i)+ &
10832                       wel_loc*gel_loc_long(j,i)+ &
10833 !el                      wcorr*gcorr_long(j,i)+ &    !el gcorr_long- brak deklaracji
10834                       wcorr5*gradcorr5_long(j,i)+ &
10835                       wcorr6*gradcorr6_long(j,i)+ &
10836                       wturn6*gcorr6_turn_long(j,i))+ &
10837                       wbond*gradb(j,i)+ &
10838                       wcorr*gradcorr(j,i)+ &
10839                       wturn3*gcorr3_turn(j,i)+ &
10840                       wturn4*gcorr4_turn(j,i)+ &
10841                       wcorr5*gradcorr5(j,i)+ &
10842                       wcorr6*gradcorr6(j,i)+ &
10843                       wturn6*gcorr6_turn(j,i)+ &
10844                       wsccor*gsccorc(j,i) &
10845                      +wscloc*gscloc(j,i) &
10846                      +gradafm(j,i) &
10847                      +wliptran*gliptranc(j,i) &
10848                      +welec*gshieldc(j,i) &
10849                      +welec*gshieldc_loc(j,) &
10850                      +wcorr*gshieldc_ec(j,i) &
10851                      +wcorr*gshieldc_loc_ec(j,i) &
10852                      +wturn3*gshieldc_t3(j,i) &
10853                      +wturn3*gshieldc_loc_t3(j,i) &
10854                      +wturn4*gshieldc_t4(j,i) &
10855                      +wturn4*gshieldc_loc_t4(j,i) &
10856                      +wel_loc*gshieldc_ll(j,i) &
10857                      +wel_loc*gshieldc_loc_ll(j,i) &
10858                      +wtube*gg_tube(j,i) &
10859                      +wbond_nucl*gradb_nucl(j,i) &
10860                      +0.5d0*(wvdwpp_nucl*gvdwpp_nucl(j,i)+welpp*gelpp(j,i)&
10861                      +wvdwpsb*gvdwpsb1(j,i))&
10862                      +wsbloc*gsbloc(j,i)
10863
10864
10865
10866
10867 #endif
10868           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+ &
10869                         wbond*gradbx(j,i)+ &
10870                         wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+ &
10871                         wsccor*gsccorx(j,i) &
10872                        +wscloc*gsclocx(j,i) &
10873                        +wliptran*gliptranx(j,i) &
10874                        +welec*gshieldx(j,i)     &
10875                        +wcorr*gshieldx_ec(j,i)  &
10876                        +wturn3*gshieldx_t3(j,i) &
10877                        +wturn4*gshieldx_t4(j,i) &
10878                        +wel_loc*gshieldx_ll(j,i)&
10879                        +wtube*gg_tube_sc(j,i)   &
10880                        +wbond_nucl*gradbx_nucl(j,i) &
10881                        +wvdwsb*gvdwsbx(j,i) &
10882                        +welsb*gelsbx(j,i) &
10883                        +wcorr_nucl*gradxorr_nucl(j,i)&
10884                        +wcorr3_nucl*gradxorr3_nucl(j,i) &
10885                        +wsbloc*gsblocx(j,i) &
10886                        +wcatprot* gradpepcatx(j,i)&
10887                        +wscbase*gvdwx_scbase(j,i) &
10888                        +wpepbase*gvdwx_pepbase(j,i)&
10889                        +wscpho*gvdwx_scpho(j,i)
10890 !              if (i.eq.3) print *,"tu?", wscpho,gvdwx_scpho(j,i)
10891
10892         enddo
10893       enddo
10894 !#define DEBUG
10895 #ifdef DEBUG
10896       write (iout,*) "gloc before adding corr"
10897       do i=1,4*nres
10898         write (iout,*) i,gloc(i,icg)
10899       enddo
10900 #endif
10901       do i=1,nres-3
10902         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i) &
10903          +wcorr5*g_corr5_loc(i) &
10904          +wcorr6*g_corr6_loc(i) &
10905          +wturn4*gel_loc_turn4(i) &
10906          +wturn3*gel_loc_turn3(i) &
10907          +wturn6*gel_loc_turn6(i) &
10908          +wel_loc*gel_loc_loc(i)
10909       enddo
10910 #ifdef DEBUG
10911       write (iout,*) "gloc after adding corr"
10912       do i=1,4*nres
10913         write (iout,*) i,gloc(i,icg)
10914       enddo
10915 #endif
10916 !#undef DEBUG
10917 #ifdef MPI
10918       if (nfgtasks.gt.1) then
10919         do j=1,3
10920           do i=0,nres
10921             gradbufc(j,i)=gradc(j,i,icg)
10922             gradbufx(j,i)=gradx(j,i,icg)
10923           enddo
10924         enddo
10925         do i=1,4*nres
10926           glocbuf(i)=gloc(i,icg)
10927         enddo
10928 !#define DEBUG
10929 #ifdef DEBUG
10930       write (iout,*) "gloc_sc before reduce"
10931       do i=1,nres
10932        do j=1,1
10933         write (iout,*) i,j,gloc_sc(j,i,icg)
10934        enddo
10935       enddo
10936 #endif
10937 !#undef DEBUG
10938         do i=1,nres
10939          do j=1,3
10940           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
10941          enddo
10942         enddo
10943         time00=MPI_Wtime()
10944         call MPI_Barrier(FG_COMM,IERR)
10945         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
10946         time00=MPI_Wtime()
10947         call MPI_Reduce(gradbufc(1,0),gradc(1,0,icg),3*nres+3,&
10948           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10949         call MPI_Reduce(gradbufx(1,0),gradx(1,0,icg),3*nres+3,&
10950           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10951         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,&
10952           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10953         time_reduce=time_reduce+MPI_Wtime()-time00
10954         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,&
10955           MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
10956         time_reduce=time_reduce+MPI_Wtime()-time00
10957 !#define DEBUG
10958 !          print *,"gradbuf",gradbufc(1,1),gradc(1,1,icg)
10959 #ifdef DEBUG
10960       write (iout,*) "gloc_sc after reduce"
10961       do i=1,nres
10962        do j=1,1
10963         write (iout,*) i,j,gloc_sc(j,i,icg)
10964        enddo
10965       enddo
10966 #endif
10967 !#undef DEBUG
10968 #ifdef DEBUG
10969       write (iout,*) "gloc after reduce"
10970       do i=1,4*nres
10971         write (iout,*) i,gloc(i,icg)
10972       enddo
10973 #endif
10974       endif
10975 #endif
10976       if (gnorm_check) then
10977 !
10978 ! Compute the maximum elements of the gradient
10979 !
10980       gvdwc_max=0.0d0
10981       gvdwc_scp_max=0.0d0
10982       gelc_max=0.0d0
10983       gvdwpp_max=0.0d0
10984       gradb_max=0.0d0
10985       ghpbc_max=0.0d0
10986       gradcorr_max=0.0d0
10987       gel_loc_max=0.0d0
10988       gcorr3_turn_max=0.0d0
10989       gcorr4_turn_max=0.0d0
10990       gradcorr5_max=0.0d0
10991       gradcorr6_max=0.0d0
10992       gcorr6_turn_max=0.0d0
10993       gsccorc_max=0.0d0
10994       gscloc_max=0.0d0
10995       gvdwx_max=0.0d0
10996       gradx_scp_max=0.0d0
10997       ghpbx_max=0.0d0
10998       gradxorr_max=0.0d0
10999       gsccorx_max=0.0d0
11000       gsclocx_max=0.0d0
11001       do i=1,nct
11002         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
11003         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
11004         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
11005         if (gvdwc_scp_norm.gt.gvdwc_scp_max) &
11006          gvdwc_scp_max=gvdwc_scp_norm
11007         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
11008         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
11009         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
11010         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
11011         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
11012         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
11013         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
11014         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
11015         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
11016         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
11017         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
11018         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
11019         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),&
11020           gcorr3_turn(1,i)))
11021         if (gcorr3_turn_norm.gt.gcorr3_turn_max) &
11022           gcorr3_turn_max=gcorr3_turn_norm
11023         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),&
11024           gcorr4_turn(1,i)))
11025         if (gcorr4_turn_norm.gt.gcorr4_turn_max) &
11026           gcorr4_turn_max=gcorr4_turn_norm
11027         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
11028         if (gradcorr5_norm.gt.gradcorr5_max) &
11029           gradcorr5_max=gradcorr5_norm
11030         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
11031         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
11032         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),&
11033           gcorr6_turn(1,i)))
11034         if (gcorr6_turn_norm.gt.gcorr6_turn_max) &
11035           gcorr6_turn_max=gcorr6_turn_norm
11036         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
11037         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
11038         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
11039         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
11040         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
11041         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
11042         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
11043         if (gradx_scp_norm.gt.gradx_scp_max) &
11044           gradx_scp_max=gradx_scp_norm
11045         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
11046         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
11047         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
11048         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
11049         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
11050         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
11051         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
11052         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
11053       enddo
11054       if (gradout) then
11055 #ifdef AIX
11056         open(istat,file=statname,position="append")
11057 #else
11058         open(istat,file=statname,access="append")
11059 #endif
11060         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,&
11061            gelc_max,gvdwpp_max,gradb_max,ghpbc_max,&
11062            gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,&
11063            gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,&
11064            gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,&
11065            gsccorx_max,gsclocx_max
11066         close(istat)
11067         if (gvdwc_max.gt.1.0d4) then
11068           write (iout,*) "gvdwc gvdwx gradb gradbx"
11069           do i=nnt,nct
11070             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),&
11071               gradb(j,i),gradbx(j,i),j=1,3)
11072           enddo
11073           call pdbout(0.0d0,'cipiszcze',iout)
11074           call flush(iout)
11075         endif
11076       endif
11077       endif
11078 !#define DEBUG
11079 #ifdef DEBUG
11080       write (iout,*) "gradc gradx gloc"
11081       do i=1,nres
11082         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)') &
11083          i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
11084       enddo
11085 #endif
11086 !#undef DEBUG
11087 #ifdef TIMING
11088       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
11089 #endif
11090       return
11091       end subroutine sum_gradient
11092 !-----------------------------------------------------------------------------
11093       subroutine sc_grad
11094 !      implicit real*8 (a-h,o-z)
11095       use calc_data
11096 !      include 'DIMENSIONS'
11097 !      include 'COMMON.CHAIN'
11098 !      include 'COMMON.DERIV'
11099 !      include 'COMMON.CALC'
11100 !      include 'COMMON.IOUNITS'
11101       real(kind=8), dimension(3) :: dcosom1,dcosom2
11102 !      print *,"wchodze"
11103       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1 &
11104           +dCAVdOM1+ dGCLdOM1+ dPOLdOM1
11105       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2 &
11106           +dCAVdOM2+ dGCLdOM2+ dPOLdOM2
11107
11108       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
11109            -2.0D0*alf12*eps3der+sigder*sigsq_om12&
11110            +dCAVdOM12+ dGCLdOM12
11111 ! diagnostics only
11112 !      eom1=0.0d0
11113 !      eom2=0.0d0
11114 !      eom12=evdwij*eps1_om12
11115 ! end diagnostics
11116 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,&
11117 !       " sigder",sigder
11118 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
11119 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
11120 !C      print *,sss_ele_cut,'in sc_grad'
11121       do k=1,3
11122         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
11123         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
11124       enddo
11125       do k=1,3
11126         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss_ele_cut
11127 !C      print *,'gg',k,gg(k)
11128        enddo
11129 !       print *,i,j,gg_lipi(3),gg_lipj(3),sss_ele_cut
11130 !      write (iout,*) "gg",(gg(k),k=1,3)
11131       do k=1,3
11132         gvdwx(k,i)=gvdwx(k,i)-gg(k) +gg_lipi(k)&
11133                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11134                   +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv    &
11135                   *sss_ele_cut
11136
11137         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)&
11138                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11139                   +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv    &
11140                   *sss_ele_cut
11141
11142 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
11143 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
11144 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
11145 !               +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
11146       enddo
11147 !
11148 ! Calculate the components of the gradient in DC and X
11149 !
11150 !grad      do k=i,j-1
11151 !grad        do l=1,3
11152 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
11153 !grad        enddo
11154 !grad      enddo
11155       do l=1,3
11156         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
11157         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
11158       enddo
11159       return
11160       end subroutine sc_grad
11161 #ifdef CRYST_THETA
11162 !-----------------------------------------------------------------------------
11163       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
11164
11165       use comm_calcthet
11166 !      implicit real*8 (a-h,o-z)
11167 !      include 'DIMENSIONS'
11168 !      include 'COMMON.LOCAL'
11169 !      include 'COMMON.IOUNITS'
11170 !el      real(kind=8) :: term1,term2,termm,diffak,ratak,&
11171 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11172 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,
11173       real(kind=8) :: thetai,thet_pred_mean,theta0i,E_tc_t
11174       real(kind=8) :: t3,t6,t9,t12,t14,t16,t21,t23,t26,t27,t32,t40
11175 !el      integer :: it
11176 !el      common /calcthet/ term1,term2,termm,diffak,ratak,&
11177 !el       ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,&
11178 !el       delthe0,sig0inv,sigtc,sigsqtc,delthec,it
11179 !el local variables
11180
11181       delthec=thetai-thet_pred_mean
11182       delthe0=thetai-theta0i
11183 ! "Thank you" to MAPLE (probably spared one day of hand-differentiation).
11184       t3 = thetai-thet_pred_mean
11185       t6 = t3**2
11186       t9 = term1
11187       t12 = t3*sigcsq
11188       t14 = t12+t6*sigsqtc
11189       t16 = 1.0d0
11190       t21 = thetai-theta0i
11191       t23 = t21**2
11192       t26 = term2
11193       t27 = t21*t26
11194       t32 = termexp
11195       t40 = t32**2
11196       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9 &
11197        -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40 &
11198        *(-t12*t9-ak*sig0inv*t27)
11199       return
11200       end subroutine mixder
11201 #endif
11202 !-----------------------------------------------------------------------------
11203 ! cartder.F
11204 !-----------------------------------------------------------------------------
11205       subroutine cartder
11206 !-----------------------------------------------------------------------------
11207 ! This subroutine calculates the derivatives of the consecutive virtual
11208 ! bond vectors and the SC vectors in the virtual-bond angles theta and
11209 ! virtual-torsional angles phi, as well as the derivatives of SC vectors
11210 ! in the angles alpha and omega, describing the location of a side chain
11211 ! in its local coordinate system.
11212 !
11213 ! The derivatives are stored in the following arrays:
11214 !
11215 ! DDCDV - the derivatives of virtual-bond vectors DC in theta and phi.
11216 ! The structure is as follows:
11217 !
11218 ! dDC(x,2)/dT(3),...,dDC(z,2)/dT(3),0,             0,             0
11219 ! 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)
11220 !         . . . . . . . . . . . .  . . . . . .
11221 ! 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)
11222 !                          .
11223 !                          .
11224 !                          .
11225 ! 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)
11226 !
11227 ! DXDV - the derivatives of the side-chain vectors in theta and phi.
11228 ! The structure is same as above.
11229 !
11230 ! DCDS - the derivatives of the side chain vectors in the local spherical
11231 ! andgles alph and omega:
11232 !
11233 ! 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)
11234 ! 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)
11235 !                          .
11236 !                          .
11237 !                          .
11238 ! 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)
11239 !
11240 ! Version of March '95, based on an early version of November '91.
11241 !
11242 !**********************************************************************
11243 !      implicit real*8 (a-h,o-z)
11244 !      include 'DIMENSIONS'
11245 !      include 'COMMON.VAR'
11246 !      include 'COMMON.CHAIN'
11247 !      include 'COMMON.DERIV'
11248 !      include 'COMMON.GEO'
11249 !      include 'COMMON.LOCAL'
11250 !      include 'COMMON.INTERACT'
11251       real(kind=8),dimension(3,3,nres) :: drt,rdt,prordt,prodrt !(3,3,maxres)
11252       real(kind=8),dimension(3,3) :: dp,temp
11253 !el      real(kind=8) :: fromto(3,3,maxdim)  !(3,3,maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
11254       real(kind=8),dimension(3) :: xx,xx1
11255 !el local variables
11256       integer :: i,k,l,j,m,ind,ind1,jjj
11257       real(kind=8) :: alphi,omegi,theta2,dpkl,dpjk,xj,rj,dxoijk,dxoiij,&
11258                  tempkl,dsci,cosalphi,sinalphi,cosomegi,sinomegi,cost2,&
11259                  sint2,xp,yp,xxp,yyp,zzp,dj
11260
11261 !      common /przechowalnia/ fromto
11262       if(.not. allocated(fromto)) allocate(fromto(3,3,maxdim))
11263 ! get the position of the jth ijth fragment of the chain coordinate system
11264 ! in the fromto array.
11265 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11266 !
11267 !      maxdim=(nres-1)*(nres-2)/2
11268 !      allocate(dcdv(6,maxdim),dxds(6,nres))
11269 ! calculate the derivatives of transformation matrix elements in theta
11270 !
11271
11272 !el      call flush(iout) !el
11273       do i=1,nres-2
11274         rdt(1,1,i)=-rt(1,2,i)
11275         rdt(1,2,i)= rt(1,1,i)
11276         rdt(1,3,i)= 0.0d0
11277         rdt(2,1,i)=-rt(2,2,i)
11278         rdt(2,2,i)= rt(2,1,i)
11279         rdt(2,3,i)= 0.0d0
11280         rdt(3,1,i)=-rt(3,2,i)
11281         rdt(3,2,i)= rt(3,1,i)
11282         rdt(3,3,i)= 0.0d0
11283       enddo
11284 !
11285 ! derivatives in phi
11286 !
11287       do i=2,nres-2
11288         drt(1,1,i)= 0.0d0
11289         drt(1,2,i)= 0.0d0
11290         drt(1,3,i)= 0.0d0
11291         drt(2,1,i)= rt(3,1,i)
11292         drt(2,2,i)= rt(3,2,i)
11293         drt(2,3,i)= rt(3,3,i)
11294         drt(3,1,i)=-rt(2,1,i)
11295         drt(3,2,i)=-rt(2,2,i)
11296         drt(3,3,i)=-rt(2,3,i)
11297       enddo
11298 !
11299 ! generate the matrix products of type r(i)t(i)...r(j)t(j)
11300 !
11301       do i=2,nres-2
11302         ind=indmat(i,i+1)
11303         do k=1,3
11304           do l=1,3
11305             temp(k,l)=rt(k,l,i)
11306           enddo
11307         enddo
11308         do k=1,3
11309           do l=1,3
11310             fromto(k,l,ind)=temp(k,l)
11311           enddo
11312         enddo
11313         do j=i+1,nres-2
11314           ind=indmat(i,j+1)
11315           do k=1,3
11316             do l=1,3
11317               dpkl=0.0d0
11318               do m=1,3
11319                 dpkl=dpkl+temp(k,m)*rt(m,l,j)
11320               enddo
11321               dp(k,l)=dpkl
11322               fromto(k,l,ind)=dpkl
11323             enddo
11324           enddo
11325           do k=1,3
11326             do l=1,3
11327               temp(k,l)=dp(k,l)
11328             enddo
11329           enddo
11330         enddo
11331       enddo
11332 !
11333 ! Calculate derivatives.
11334 !
11335       ind1=0
11336       do i=1,nres-2
11337       ind1=ind1+1
11338 !
11339 ! Derivatives of DC(i+1) in theta(i+2)
11340 !
11341         do j=1,3
11342           do k=1,2
11343             dpjk=0.0D0
11344             do l=1,3
11345               dpjk=dpjk+prod(j,l,i)*rdt(l,k,i)
11346             enddo
11347             dp(j,k)=dpjk
11348             prordt(j,k,i)=dp(j,k)
11349           enddo
11350           dp(j,3)=0.0D0
11351           dcdv(j,ind1)=vbld(i+1)*dp(j,1)
11352         enddo
11353 !
11354 ! Derivatives of SC(i+1) in theta(i+2)
11355 !
11356         xx1(1)=-0.5D0*xloc(2,i+1)
11357         xx1(2)= 0.5D0*xloc(1,i+1)
11358         do j=1,3
11359           xj=0.0D0
11360           do k=1,2
11361             xj=xj+r(j,k,i)*xx1(k)
11362           enddo
11363           xx(j)=xj
11364         enddo
11365         do j=1,3
11366           rj=0.0D0
11367           do k=1,3
11368             rj=rj+prod(j,k,i)*xx(k)
11369           enddo
11370           dxdv(j,ind1)=rj
11371         enddo
11372 !
11373 ! Derivatives of SC(i+1) in theta(i+3). The have to be handled differently
11374 ! than the other off-diagonal derivatives.
11375 !
11376         do j=1,3
11377           dxoiij=0.0D0
11378           do k=1,3
11379             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11380           enddo
11381           dxdv(j,ind1+1)=dxoiij
11382         enddo
11383 !d      print *,ind1+1,(dxdv(j,ind1+1),j=1,3)
11384 !
11385 ! Derivatives of DC(i+1) in phi(i+2)
11386 !
11387         do j=1,3
11388           do k=1,3
11389             dpjk=0.0
11390             do l=2,3
11391               dpjk=dpjk+prod(j,l,i)*drt(l,k,i)
11392             enddo
11393             dp(j,k)=dpjk
11394             prodrt(j,k,i)=dp(j,k)
11395           enddo
11396           dcdv(j+3,ind1)=vbld(i+1)*dp(j,1)
11397         enddo
11398 !
11399 ! Derivatives of SC(i+1) in phi(i+2)
11400 !
11401         xx(1)= 0.0D0
11402         xx(3)= xloc(2,i+1)*r(2,2,i)+xloc(3,i+1)*r(2,3,i)
11403         xx(2)=-xloc(2,i+1)*r(3,2,i)-xloc(3,i+1)*r(3,3,i)
11404         do j=1,3
11405           rj=0.0D0
11406           do k=2,3
11407             rj=rj+prod(j,k,i)*xx(k)
11408           enddo
11409           dxdv(j+3,ind1)=-rj
11410         enddo
11411 !
11412 ! Derivatives of SC(i+1) in phi(i+3).
11413 !
11414         do j=1,3
11415           dxoiij=0.0D0
11416           do k=1,3
11417             dxoiij=dxoiij+dp(j,k)*xrot(k,i+2)
11418           enddo
11419           dxdv(j+3,ind1+1)=dxoiij
11420         enddo
11421 !
11422 ! Calculate the derivatives of DC(i+1) and SC(i+1) in theta(i+3) thru
11423 ! theta(nres) and phi(i+3) thru phi(nres).
11424 !
11425         do j=i+1,nres-2
11426         ind1=ind1+1
11427         ind=indmat(i+1,j+1)
11428 !d        print *,'i=',i,' j=',j,' ind=',ind,' ind1=',ind1
11429           do k=1,3
11430             do l=1,3
11431               tempkl=0.0D0
11432               do m=1,2
11433                 tempkl=tempkl+prordt(k,m,i)*fromto(m,l,ind)
11434               enddo
11435               temp(k,l)=tempkl
11436             enddo
11437           enddo
11438 !d        print '(9f8.3)',((fromto(k,l,ind),l=1,3),k=1,3)
11439 !d        print '(9f8.3)',((prod(k,l,i),l=1,3),k=1,3)
11440 !d        print '(9f8.3)',((temp(k,l),l=1,3),k=1,3)
11441 ! Derivatives of virtual-bond vectors in theta
11442           do k=1,3
11443             dcdv(k,ind1)=vbld(i+1)*temp(k,1)
11444           enddo
11445 !d        print '(3f8.3)',(dcdv(k,ind1),k=1,3)
11446 ! Derivatives of SC vectors in theta
11447           do k=1,3
11448             dxoijk=0.0D0
11449             do l=1,3
11450               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11451             enddo
11452             dxdv(k,ind1+1)=dxoijk
11453           enddo
11454 !
11455 !--- Calculate the derivatives in phi
11456 !
11457           do k=1,3
11458             do l=1,3
11459               tempkl=0.0D0
11460               do m=1,3
11461                 tempkl=tempkl+prodrt(k,m,i)*fromto(m,l,ind)
11462               enddo
11463               temp(k,l)=tempkl
11464             enddo
11465           enddo
11466           do k=1,3
11467             dcdv(k+3,ind1)=vbld(i+1)*temp(k,1)
11468         enddo
11469           do k=1,3
11470             dxoijk=0.0D0
11471             do l=1,3
11472               dxoijk=dxoijk+temp(k,l)*xrot(l,j+2)
11473             enddo
11474             dxdv(k+3,ind1+1)=dxoijk
11475           enddo
11476         enddo
11477       enddo
11478 !
11479 ! Derivatives in alpha and omega:
11480 !
11481       do i=2,nres-1
11482 !       dsci=dsc(itype(i,1))
11483         dsci=vbld(i+nres)
11484 #ifdef OSF
11485         alphi=alph(i)
11486         omegi=omeg(i)
11487         if(alphi.ne.alphi) alphi=100.0
11488         if(omegi.ne.omegi) omegi=-100.0
11489 #else
11490       alphi=alph(i)
11491       omegi=omeg(i)
11492 #endif
11493 !d      print *,'i=',i,' dsci=',dsci,' alphi=',alphi,' omegi=',omegi
11494       cosalphi=dcos(alphi)
11495       sinalphi=dsin(alphi)
11496       cosomegi=dcos(omegi)
11497       sinomegi=dsin(omegi)
11498       temp(1,1)=-dsci*sinalphi
11499       temp(2,1)= dsci*cosalphi*cosomegi
11500       temp(3,1)=-dsci*cosalphi*sinomegi
11501       temp(1,2)=0.0D0
11502       temp(2,2)=-dsci*sinalphi*sinomegi
11503       temp(3,2)=-dsci*sinalphi*cosomegi
11504       theta2=pi-0.5D0*theta(i+1)
11505       cost2=dcos(theta2)
11506       sint2=dsin(theta2)
11507       jjj=0
11508 !d      print *,((temp(l,k),l=1,3),k=1,2)
11509         do j=1,2
11510         xp=temp(1,j)
11511         yp=temp(2,j)
11512         xxp= xp*cost2+yp*sint2
11513         yyp=-xp*sint2+yp*cost2
11514         zzp=temp(3,j)
11515         xx(1)=xxp
11516         xx(2)=yyp*r(2,2,i-1)+zzp*r(2,3,i-1)
11517         xx(3)=yyp*r(3,2,i-1)+zzp*r(3,3,i-1)
11518         do k=1,3
11519           dj=0.0D0
11520           do l=1,3
11521             dj=dj+prod(k,l,i-1)*xx(l)
11522             enddo
11523           dxds(jjj+k,i)=dj
11524           enddo
11525         jjj=jjj+3
11526       enddo
11527       enddo
11528       return
11529       end subroutine cartder
11530 !-----------------------------------------------------------------------------
11531 ! checkder_p.F
11532 !-----------------------------------------------------------------------------
11533       subroutine check_cartgrad
11534 ! Check the gradient of Cartesian coordinates in internal coordinates.
11535 !      implicit real*8 (a-h,o-z)
11536 !      include 'DIMENSIONS'
11537 !      include 'COMMON.IOUNITS'
11538 !      include 'COMMON.VAR'
11539 !      include 'COMMON.CHAIN'
11540 !      include 'COMMON.GEO'
11541 !      include 'COMMON.LOCAL'
11542 !      include 'COMMON.DERIV'
11543       real(kind=8),dimension(6,nres) :: temp
11544       real(kind=8),dimension(3) :: xx,gg
11545       integer :: i,k,j,ii
11546       real(kind=8) :: aincr,aincr2,alphi,omegi,theti,thet,phii
11547 !      indmat(i,j)=((2*(nres-2)-i)*(i-1))/2+j-1
11548 !
11549 ! Check the gradient of the virtual-bond and SC vectors in the internal
11550 ! coordinates.
11551 !
11552       aincr=1.0d-6
11553       aincr2=5.0d-7
11554       call cartder
11555       write (iout,'(a)') '**************** dx/dalpha'
11556       write (iout,'(a)')
11557       do i=2,nres-1
11558       alphi=alph(i)
11559       alph(i)=alph(i)+aincr
11560       do k=1,3
11561         temp(k,i)=dc(k,nres+i)
11562         enddo
11563       call chainbuild
11564       do k=1,3
11565         gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11566         xx(k)=dabs((gg(k)-dxds(k,i))/(aincr*dabs(dxds(k,i))+aincr))
11567         enddo
11568         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11569         i,(gg(k),k=1,3),(dxds(k,i),k=1,3),(xx(k),k=1,3)
11570         write (iout,'(a)')
11571       alph(i)=alphi
11572       call chainbuild
11573       enddo
11574       write (iout,'(a)')
11575       write (iout,'(a)') '**************** dx/domega'
11576       write (iout,'(a)')
11577       do i=2,nres-1
11578       omegi=omeg(i)
11579       omeg(i)=omeg(i)+aincr
11580       do k=1,3
11581         temp(k,i)=dc(k,nres+i)
11582         enddo
11583       call chainbuild
11584       do k=1,3
11585           gg(k)=(dc(k,nres+i)-temp(k,i))/aincr
11586           xx(k)=dabs((gg(k)-dxds(k+3,i))/ &
11587                 (aincr*dabs(dxds(k+3,i))+aincr))
11588         enddo
11589         write (iout,'(i4,3e15.6/4x,3e15.6,3f9.3)') &
11590             i,(gg(k),k=1,3),(dxds(k+3,i),k=1,3),(xx(k),k=1,3)
11591         write (iout,'(a)')
11592       omeg(i)=omegi
11593       call chainbuild
11594       enddo
11595       write (iout,'(a)')
11596       write (iout,'(a)') '**************** dx/dtheta'
11597       write (iout,'(a)')
11598       do i=3,nres
11599       theti=theta(i)
11600         theta(i)=theta(i)+aincr
11601         do j=i-1,nres-1
11602           do k=1,3
11603             temp(k,j)=dc(k,nres+j)
11604           enddo
11605         enddo
11606         call chainbuild
11607         do j=i-1,nres-1
11608         ii = indmat(i-2,j)
11609 !         print *,'i=',i-2,' j=',j-1,' ii=',ii
11610         do k=1,3
11611           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11612           xx(k)=dabs((gg(k)-dxdv(k,ii))/ &
11613                   (aincr*dabs(dxdv(k,ii))+aincr))
11614           enddo
11615           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11616               i,j,(gg(k),k=1,3),(dxdv(k,ii),k=1,3),(xx(k),k=1,3)
11617           write(iout,'(a)')
11618         enddo
11619         write (iout,'(a)')
11620         theta(i)=theti
11621         call chainbuild
11622       enddo
11623       write (iout,'(a)') '***************** dx/dphi'
11624       write (iout,'(a)')
11625       do i=4,nres
11626         phi(i)=phi(i)+aincr
11627         do j=i-1,nres-1
11628           do k=1,3
11629             temp(k,j)=dc(k,nres+j)
11630           enddo
11631         enddo
11632         call chainbuild
11633         do j=i-1,nres-1
11634         ii = indmat(i-2,j)
11635 !         print *,'ii=',ii
11636         do k=1,3
11637           gg(k)=(dc(k,nres+j)-temp(k,j))/aincr
11638             xx(k)=dabs((gg(k)-dxdv(k+3,ii))/ &
11639                   (aincr*dabs(dxdv(k+3,ii))+aincr))
11640           enddo
11641           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11642               i,j,(gg(k),k=1,3),(dxdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11643           write(iout,'(a)')
11644         enddo
11645         phi(i)=phi(i)-aincr
11646         call chainbuild
11647       enddo
11648       write (iout,'(a)') '****************** ddc/dtheta'
11649       do i=1,nres-2
11650         thet=theta(i+2)
11651         theta(i+2)=thet+aincr
11652         do j=i,nres
11653           do k=1,3
11654             temp(k,j)=dc(k,j)
11655           enddo
11656         enddo
11657         call chainbuild
11658         do j=i+1,nres-1
11659         ii = indmat(i,j)
11660 !         print *,'ii=',ii
11661         do k=1,3
11662           gg(k)=(dc(k,j)-temp(k,j))/aincr
11663           xx(k)=dabs((gg(k)-dcdv(k,ii))/ &
11664                  (aincr*dabs(dcdv(k,ii))+aincr))
11665           enddo
11666           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11667                  i,j,(gg(k),k=1,3),(dcdv(k,ii),k=1,3),(xx(k),k=1,3)
11668         write (iout,'(a)')
11669         enddo
11670         do j=1,nres
11671           do k=1,3
11672             dc(k,j)=temp(k,j)
11673           enddo
11674         enddo
11675         theta(i+2)=thet
11676       enddo
11677       write (iout,'(a)') '******************* ddc/dphi'
11678       do i=1,nres-3
11679         phii=phi(i+3)
11680         phi(i+3)=phii+aincr
11681         do j=1,nres
11682           do k=1,3
11683             temp(k,j)=dc(k,j)
11684           enddo
11685         enddo
11686         call chainbuild
11687         do j=i+2,nres-1
11688         ii = indmat(i+1,j)
11689 !         print *,'ii=',ii
11690         do k=1,3
11691           gg(k)=(dc(k,j)-temp(k,j))/aincr
11692             xx(k)=dabs((gg(k)-dcdv(k+3,ii))/ &
11693                  (aincr*dabs(dcdv(k+3,ii))+aincr))
11694           enddo
11695           write (iout,'(2i4,3e14.6/8x,3e14.6,3f9.3)') &
11696                i,j,(gg(k),k=1,3),(dcdv(k+3,ii),k=1,3),(xx(k),k=1,3)
11697         write (iout,'(a)')
11698         enddo
11699         do j=1,nres
11700           do k=1,3
11701             dc(k,j)=temp(k,j)
11702           enddo
11703         enddo
11704         phi(i+3)=phii
11705       enddo
11706       return
11707       end subroutine check_cartgrad
11708 !-----------------------------------------------------------------------------
11709       subroutine check_ecart
11710 ! Check the gradient of the energy in Cartesian coordinates.
11711 !     implicit real*8 (a-h,o-z)
11712 !     include 'DIMENSIONS'
11713 !     include 'COMMON.CHAIN'
11714 !     include 'COMMON.DERIV'
11715 !     include 'COMMON.IOUNITS'
11716 !     include 'COMMON.VAR'
11717 !     include 'COMMON.CONTACTS'
11718       use comm_srutu
11719 !el      integer :: icall
11720 !el      common /srutu/ icall
11721       real(kind=8),dimension(6) :: ggg
11722       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
11723       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11724       real(kind=8),dimension(6,nres) :: grad_s
11725       real(kind=8),dimension(0:n_ene) :: energia,energia1
11726       integer :: uiparm(1)
11727       real(kind=8) :: urparm(1)
11728 !EL      external fdum
11729       integer :: nf,i,j,k
11730       real(kind=8) :: aincr,etot,etot1
11731       icg=1
11732       nf=0
11733       nfl=0
11734       call zerograd
11735       aincr=1.0D-5
11736       print '(a)','CG processor',me,' calling CHECK_CART.',aincr
11737       nf=0
11738       icall=0
11739       call geom_to_var(nvar,x)
11740       call etotal(energia)
11741       etot=energia(0)
11742 !el      call enerprint(energia)
11743       call gradient(nvar,x,nf,g,uiparm,urparm,fdum)
11744       icall =1
11745       do i=1,nres
11746         write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11747       enddo
11748       do i=1,nres
11749       do j=1,3
11750         grad_s(j,i)=gradc(j,i,icg)
11751         grad_s(j+3,i)=gradx(j,i,icg)
11752         enddo
11753       enddo
11754       call flush(iout)
11755       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11756       do i=1,nres
11757         do j=1,3
11758         xx(j)=c(j,i+nres)
11759         ddc(j)=dc(j,i)
11760         ddx(j)=dc(j,i+nres)
11761         enddo
11762       do j=1,3
11763         dc(j,i)=dc(j,i)+aincr
11764         do k=i+1,nres
11765           c(j,k)=c(j,k)+aincr
11766           c(j,k+nres)=c(j,k+nres)+aincr
11767           enddo
11768           call zerograd
11769           call etotal(energia1)
11770           etot1=energia1(0)
11771         ggg(j)=(etot1-etot)/aincr
11772         dc(j,i)=ddc(j)
11773         do k=i+1,nres
11774           c(j,k)=c(j,k)-aincr
11775           c(j,k+nres)=c(j,k+nres)-aincr
11776           enddo
11777         enddo
11778       do j=1,3
11779         c(j,i+nres)=c(j,i+nres)+aincr
11780         dc(j,i+nres)=dc(j,i+nres)+aincr
11781           call zerograd
11782           call etotal(energia1)
11783           etot1=energia1(0)
11784         ggg(j+3)=(etot1-etot)/aincr
11785         c(j,i+nres)=xx(j)
11786         dc(j,i+nres)=ddx(j)
11787         enddo
11788       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/)') &
11789          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6)
11790       enddo
11791       return
11792       end subroutine check_ecart
11793 #ifdef CARGRAD
11794 !-----------------------------------------------------------------------------
11795       subroutine check_ecartint
11796 ! Check the gradient of the energy in Cartesian coordinates.
11797       use io_base, only: intout
11798 !      implicit real*8 (a-h,o-z)
11799 !      include 'DIMENSIONS'
11800 !      include 'COMMON.CONTROL'
11801 !      include 'COMMON.CHAIN'
11802 !      include 'COMMON.DERIV'
11803 !      include 'COMMON.IOUNITS'
11804 !      include 'COMMON.VAR'
11805 !      include 'COMMON.CONTACTS'
11806 !      include 'COMMON.MD'
11807 !      include 'COMMON.LOCAL'
11808 !      include 'COMMON.SPLITELE'
11809       use comm_srutu
11810 !el      integer :: icall
11811 !el      common /srutu/ icall
11812       real(kind=8),dimension(6) :: ggg,ggg1
11813       real(kind=8),dimension(3) :: cc,xx,ddc,ddx,ddc1,ddcn
11814       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
11815       real(kind=8),dimension(3) :: dcnorm_safe1,dcnorm_safe2,dxnorm_safe
11816       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
11817       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
11818       real(kind=8),dimension(0:n_ene) :: energia,energia1
11819       integer :: uiparm(1)
11820       real(kind=8) :: urparm(1)
11821 !EL      external fdum
11822       integer :: i,j,k,nf
11823       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
11824                    etot21,etot22
11825       r_cut=2.0d0
11826       rlambd=0.3d0
11827       icg=1
11828       nf=0
11829       nfl=0
11830       call intout
11831 !      call intcartderiv
11832 !      call checkintcartgrad
11833       call zerograd
11834       aincr=1.0D-4
11835       write(iout,*) 'Calling CHECK_ECARTINT.'
11836       nf=0
11837       icall=0
11838       call geom_to_var(nvar,x)
11839       write (iout,*) "split_ene ",split_ene
11840       call flush(iout)
11841       if (.not.split_ene) then
11842         call zerograd
11843         call etotal(energia)
11844         etot=energia(0)
11845         call cartgrad
11846         icall =1
11847         do i=1,nres
11848           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
11849         enddo
11850         do j=1,3
11851           grad_s(j,0)=gcart(j,0)
11852         enddo
11853         do i=1,nres
11854           do j=1,3
11855             grad_s(j,i)=gcart(j,i)
11856             grad_s(j+3,i)=gxcart(j,i)
11857           enddo
11858         enddo
11859       else
11860 !- split gradient check
11861         call zerograd
11862         call etotal_long(energia)
11863 !el        call enerprint(energia)
11864         call cartgrad
11865         icall =1
11866         do i=1,nres
11867           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11868           (gxcart(j,i),j=1,3)
11869         enddo
11870         do j=1,3
11871           grad_s(j,0)=gcart(j,0)
11872         enddo
11873         do i=1,nres
11874           do j=1,3
11875             grad_s(j,i)=gcart(j,i)
11876             grad_s(j+3,i)=gxcart(j,i)
11877           enddo
11878         enddo
11879         call zerograd
11880         call etotal_short(energia)
11881         call enerprint(energia)
11882         call cartgrad
11883         icall =1
11884         do i=1,nres
11885           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
11886           (gxcart(j,i),j=1,3)
11887         enddo
11888         do j=1,3
11889           grad_s1(j,0)=gcart(j,0)
11890         enddo
11891         do i=1,nres
11892           do j=1,3
11893             grad_s1(j,i)=gcart(j,i)
11894             grad_s1(j+3,i)=gxcart(j,i)
11895           enddo
11896         enddo
11897       endif
11898       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
11899 !      do i=1,nres
11900       do i=nnt,nct
11901         do j=1,3
11902           if (nnt.gt.1 .and. i.eq.nnt) ddc1(j)=c(j,1)
11903           if (nct.lt.nres .and. i.eq.nct) ddcn(j)=c(j,nres)
11904         ddc(j)=c(j,i)
11905         ddx(j)=c(j,i+nres)
11906           dcnorm_safe1(j)=dc_norm(j,i-1)
11907           dcnorm_safe2(j)=dc_norm(j,i)
11908           dxnorm_safe(j)=dc_norm(j,i+nres)
11909         enddo
11910       do j=1,3
11911         c(j,i)=ddc(j)+aincr
11912           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=c(j,1)+aincr
11913           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=c(j,nres)+aincr
11914           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11915           dc(j,i)=c(j,i+1)-c(j,i)
11916           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11917           call int_from_cart1(.false.)
11918           if (.not.split_ene) then
11919            call zerograd
11920             call etotal(energia1)
11921             etot1=energia1(0)
11922             write (iout,*) "ij",i,j," etot1",etot1
11923           else
11924 !- split gradient
11925             call etotal_long(energia1)
11926             etot11=energia1(0)
11927             call etotal_short(energia1)
11928             etot12=energia1(0)
11929           endif
11930 !- end split gradient
11931 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
11932         c(j,i)=ddc(j)-aincr
11933           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)-aincr
11934           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)-aincr
11935           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11936           dc(j,i)=c(j,i+1)-c(j,i)
11937           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11938           call int_from_cart1(.false.)
11939           if (.not.split_ene) then
11940             call zerograd
11941             call etotal(energia1)
11942             etot2=energia1(0)
11943             write (iout,*) "ij",i,j," etot2",etot2
11944           ggg(j)=(etot1-etot2)/(2*aincr)
11945           else
11946 !- split gradient
11947             call etotal_long(energia1)
11948             etot21=energia1(0)
11949           ggg(j)=(etot11-etot21)/(2*aincr)
11950             call etotal_short(energia1)
11951             etot22=energia1(0)
11952           ggg1(j)=(etot12-etot22)/(2*aincr)
11953 !- end split gradient
11954 !            write (iout,*) "etot21",etot21," etot22",etot22
11955           endif
11956 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
11957         c(j,i)=ddc(j)
11958           if (nnt.gt.1 .and. i.eq.nnt) c(j,1)=ddc1(j)
11959           if (nct.lt.nres .and. i.eq.nct) c(j,nres)=ddcn(j)
11960           if (i.gt.1) dc(j,i-1)=c(j,i)-c(j,i-1)
11961           dc(j,i)=c(j,i+1)-c(j,i)
11962           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11963           dc_norm(j,i-1)=dcnorm_safe1(j)
11964           dc_norm(j,i)=dcnorm_safe2(j)
11965           dc_norm(j,i+nres)=dxnorm_safe(j)
11966         enddo
11967       do j=1,3
11968         c(j,i+nres)=ddx(j)+aincr
11969           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11970           call int_from_cart1(.false.)
11971           if (.not.split_ene) then
11972             call zerograd
11973             call etotal(energia1)
11974             etot1=energia1(0)
11975           else
11976 !- split gradient
11977             call etotal_long(energia1)
11978             etot11=energia1(0)
11979             call etotal_short(energia1)
11980             etot12=energia1(0)
11981           endif
11982 !- end split gradient
11983         c(j,i+nres)=ddx(j)-aincr
11984           dc(j,i+nres)=c(j,i+nres)-c(j,i)
11985           call int_from_cart1(.false.)
11986           if (.not.split_ene) then
11987            call zerograd
11988            call etotal(energia1)
11989             etot2=energia1(0)
11990           ggg(j+3)=(etot1-etot2)/(2*aincr)
11991           else
11992 !- split gradient
11993             call etotal_long(energia1)
11994             etot21=energia1(0)
11995           ggg(j+3)=(etot11-etot21)/(2*aincr)
11996             call etotal_short(energia1)
11997             etot22=energia1(0)
11998           ggg1(j+3)=(etot12-etot22)/(2*aincr)
11999 !- end split gradient
12000           endif
12001 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12002         c(j,i+nres)=ddx(j)
12003           dc(j,i+nres)=c(j,i+nres)-c(j,i)
12004           dc_norm(j,i+nres)=dxnorm_safe(j)
12005           call int_from_cart1(.false.)
12006         enddo
12007       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12008          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12009         if (split_ene) then
12010           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12011          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12012          k=1,6)
12013          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12014          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12015          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12016         endif
12017       enddo
12018       return
12019       end subroutine check_ecartint
12020 #else
12021 !-----------------------------------------------------------------------------
12022       subroutine check_ecartint
12023 ! Check the gradient of the energy in Cartesian coordinates.
12024       use io_base, only: intout
12025 !      implicit real*8 (a-h,o-z)
12026 !      include 'DIMENSIONS'
12027 !      include 'COMMON.CONTROL'
12028 !      include 'COMMON.CHAIN'
12029 !      include 'COMMON.DERIV'
12030 !      include 'COMMON.IOUNITS'
12031 !      include 'COMMON.VAR'
12032 !      include 'COMMON.CONTACTS'
12033 !      include 'COMMON.MD'
12034 !      include 'COMMON.LOCAL'
12035 !      include 'COMMON.SPLITELE'
12036       use comm_srutu
12037 !el      integer :: icall
12038 !el      common /srutu/ icall
12039       real(kind=8),dimension(6) :: ggg,ggg1
12040       real(kind=8),dimension(3) :: cc,xx,ddc,ddx
12041       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
12042       real(kind=8),dimension(3) :: dcnorm_safe,dxnorm_safe
12043       real(kind=8),dimension(6,0:nres) :: grad_s,grad_s1 !(6,0:maxres)
12044       real(kind=8),dimension(nres) :: phi_temp,theta_temp,alph_temp,omeg_temp !(maxres)
12045       real(kind=8),dimension(0:n_ene) :: energia,energia1
12046       integer :: uiparm(1)
12047       real(kind=8) :: urparm(1)
12048 !EL      external fdum
12049       integer :: i,j,k,nf
12050       real(kind=8) :: rlambd,aincr,etot,etot1,etot11,etot12,etot2,&
12051                    etot21,etot22
12052       r_cut=2.0d0
12053       rlambd=0.3d0
12054       icg=1
12055       nf=0
12056       nfl=0
12057       call intout
12058 !      call intcartderiv
12059 !      call checkintcartgrad
12060       call zerograd
12061       aincr=2.0D-5
12062       write(iout,*) 'Calling CHECK_ECARTINT.',aincr
12063       nf=0
12064       icall=0
12065       call geom_to_var(nvar,x)
12066       if (.not.split_ene) then
12067         call etotal(energia)
12068         etot=energia(0)
12069 !el        call enerprint(energia)
12070         call cartgrad
12071         icall =1
12072         do i=1,nres
12073           write (iout,'(i5,3f10.5)') i,(gradxorr(j,i),j=1,3)
12074         enddo
12075         do j=1,3
12076           grad_s(j,0)=gcart(j,0)
12077         enddo
12078         do i=1,nres
12079           do j=1,3
12080             grad_s(j,i)=gcart(j,i)
12081 !              if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12082
12083 !            if (i.le.2) print *,"tu?!",gcart(j,i),grad_s(j,i),gxcart(j,i)
12084             grad_s(j+3,i)=gxcart(j,i)
12085           enddo
12086         enddo
12087       else
12088 !- split gradient check
12089         call zerograd
12090         call etotal_long(energia)
12091 !el        call enerprint(energia)
12092         call cartgrad
12093         icall =1
12094         do i=1,nres
12095           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12096           (gxcart(j,i),j=1,3)
12097         enddo
12098         do j=1,3
12099           grad_s(j,0)=gcart(j,0)
12100         enddo
12101         do i=1,nres
12102           do j=1,3
12103             grad_s(j,i)=gcart(j,i)
12104 !            if (i.eq.21) print *,"PRZEKAZANIE",gcart(j,i)
12105             grad_s(j+3,i)=gxcart(j,i)
12106           enddo
12107         enddo
12108         call zerograd
12109         call etotal_short(energia)
12110 !el        call enerprint(energia)
12111         call cartgrad
12112         icall =1
12113         do i=1,nres
12114           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
12115           (gxcart(j,i),j=1,3)
12116         enddo
12117         do j=1,3
12118           grad_s1(j,0)=gcart(j,0)
12119         enddo
12120         do i=1,nres
12121           do j=1,3
12122             grad_s1(j,i)=gcart(j,i)
12123             grad_s1(j+3,i)=gxcart(j,i)
12124           enddo
12125         enddo
12126       endif
12127       write (iout,'(/a/)') 'Gradient in virtual-bond and SC vectors'
12128       do i=0,nres
12129         do j=1,3
12130         xx(j)=c(j,i+nres)
12131         ddc(j)=dc(j,i)
12132         ddx(j)=dc(j,i+nres)
12133           do k=1,3
12134             dcnorm_safe(k)=dc_norm(k,i)
12135             dxnorm_safe(k)=dc_norm(k,i+nres)
12136           enddo
12137         enddo
12138       do j=1,3
12139         dc(j,i)=ddc(j)+aincr
12140           call chainbuild_cart
12141 #ifdef MPI
12142 ! Broadcast the order to compute internal coordinates to the slaves.
12143 !          if (nfgtasks.gt.1)
12144 !     &      call MPI_Bcast(6,1,MPI_INTEGER,king,FG_COMM,IERROR)
12145 #endif
12146 !          call int_from_cart1(.false.)
12147           if (.not.split_ene) then
12148            call zerograd
12149             call etotal(energia1)
12150             etot1=energia1(0)
12151 !            call enerprint(energia1)
12152           else
12153 !- split gradient
12154             call etotal_long(energia1)
12155             etot11=energia1(0)
12156             call etotal_short(energia1)
12157             etot12=energia1(0)
12158 !            write (iout,*) "etot11",etot11," etot12",etot12
12159           endif
12160 !- end split gradient
12161 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12162         dc(j,i)=ddc(j)-aincr
12163           call chainbuild_cart
12164 !          call int_from_cart1(.false.)
12165           if (.not.split_ene) then
12166                   call zerograd
12167             call etotal(energia1)
12168             etot2=energia1(0)
12169           ggg(j)=(etot1-etot2)/(2*aincr)
12170           else
12171 !- split gradient
12172             call etotal_long(energia1)
12173             etot21=energia1(0)
12174           ggg(j)=(etot11-etot21)/(2*aincr)
12175             call etotal_short(energia1)
12176             etot22=energia1(0)
12177           ggg1(j)=(etot12-etot22)/(2*aincr)
12178 !- end split gradient
12179 !            write (iout,*) "etot21",etot21," etot22",etot22
12180           endif
12181 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12182         dc(j,i)=ddc(j)
12183           call chainbuild_cart
12184         enddo
12185       do j=1,3
12186         dc(j,i+nres)=ddx(j)+aincr
12187           call chainbuild_cart
12188 !          write (iout,*) "i",i," j",j," dxnorm+ and dxnorm"
12189 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12190 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12191 !          write (iout,*) "dxnormnorm",dsqrt(
12192 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12193 !          write (iout,*) "dxnormnormsafe",dsqrt(
12194 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12195 !          write (iout,*)
12196           if (.not.split_ene) then
12197             call zerograd
12198             call etotal(energia1)
12199             etot1=energia1(0)
12200           else
12201 !- split gradient
12202             call etotal_long(energia1)
12203             etot11=energia1(0)
12204             call etotal_short(energia1)
12205             etot12=energia1(0)
12206           endif
12207 !- end split gradient
12208 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot1",etot1
12209         dc(j,i+nres)=ddx(j)-aincr
12210           call chainbuild_cart
12211 !          write (iout,*) "i",i," j",j," dxnorm- and dxnorm"
12212 !          write (iout,'(3f15.10)') (dc_norm(k,i+nres),k=1,3)
12213 !          write (iout,'(3f15.10)') (dxnorm_safe(k),k=1,3)
12214 !          write (iout,*)
12215 !          write (iout,*) "dxnormnorm",dsqrt(
12216 !     &  dc_norm(1,i+nres)**2+dc_norm(2,i+nres)**2+dc_norm(3,i+nres)**2)
12217 !          write (iout,*) "dxnormnormsafe",dsqrt(
12218 !     &      dxnorm_safe(1)**2+dxnorm_safe(2)**2+dxnorm_safe(3)**2)
12219           if (.not.split_ene) then
12220             call zerograd
12221             call etotal(energia1)
12222             etot2=energia1(0)
12223           ggg(j+3)=(etot1-etot2)/(2*aincr)
12224           else
12225 !- split gradient
12226             call etotal_long(energia1)
12227             etot21=energia1(0)
12228           ggg(j+3)=(etot11-etot21)/(2*aincr)
12229             call etotal_short(energia1)
12230             etot22=energia1(0)
12231           ggg1(j+3)=(etot12-etot22)/(2*aincr)
12232 !- end split gradient
12233           endif
12234 !          write(iout,'(2i5,2(a,f15.10))')i,j," etot",etot," etot2",etot2
12235         dc(j,i+nres)=ddx(j)
12236           call chainbuild_cart
12237         enddo
12238       write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12239          i,(ggg(k),k=1,6),(grad_s(k,i),k=1,6),(ggg(k)/grad_s(k,i),k=1,6)
12240         if (split_ene) then
12241           write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12242          i,(ggg1(k),k=1,6),(grad_s1(k,i),k=1,6),(ggg1(k)/grad_s1(k,i),&
12243          k=1,6)
12244          write (iout,'(i3,6(1pe12.5)/3x,6(1pe12.5)/3x,6(1pe12.5)/)') &
12245          i,(ggg(k)+ggg1(k),k=1,6),(grad_s(k,i)+grad_s1(k,i),k=1,6),&
12246          ((ggg(k)+ggg1(k))/(grad_s(k,i)+grad_s1(k,i)),k=1,6)
12247         endif
12248       enddo
12249       return
12250       end subroutine check_ecartint
12251 #endif
12252 !-----------------------------------------------------------------------------
12253       subroutine check_eint
12254 ! Check the gradient of energy in internal coordinates.
12255 !      implicit real*8 (a-h,o-z)
12256 !      include 'DIMENSIONS'
12257 !      include 'COMMON.CHAIN'
12258 !      include 'COMMON.DERIV'
12259 !      include 'COMMON.IOUNITS'
12260 !      include 'COMMON.VAR'
12261 !      include 'COMMON.GEO'
12262       use comm_srutu
12263 !el      integer :: icall
12264 !el      common /srutu/ icall
12265       real(kind=8),dimension(6*nres) :: x,gana,gg !(maxvar) (maxvar=6*maxres)
12266       integer :: uiparm(1)
12267       real(kind=8) :: urparm(1)
12268       real(kind=8),dimension(0:n_ene) :: energia,energia1,energia2
12269       character(len=6) :: key
12270 !EL      external fdum
12271       integer :: i,ii,nf
12272       real(kind=8) :: xi,aincr,etot,etot1,etot2
12273       call zerograd
12274       aincr=1.0D-7
12275       print '(a)','Calling CHECK_INT.'
12276       nf=0
12277       nfl=0
12278       icg=1
12279       call geom_to_var(nvar,x)
12280       call var_to_geom(nvar,x)
12281       call chainbuild
12282       icall=1
12283 !      print *,'ICG=',ICG
12284       call etotal(energia)
12285       etot = energia(0)
12286 !el      call enerprint(energia)
12287 !      print *,'ICG=',ICG
12288 #ifdef MPL
12289       if (MyID.ne.BossID) then
12290         call mp_bcast(x(1),8*(nvar+3),BossID,fgGroupID)
12291         nf=x(nvar+1)
12292         nfl=x(nvar+2)
12293         icg=x(nvar+3)
12294       endif
12295 #endif
12296       nf=1
12297       nfl=3
12298 !d    write (iout,'(10f8.3)') (rad2deg*x(i),i=1,nvar)
12299       call gradient(nvar,x,nf,gana,uiparm,urparm,fdum)
12300 !d     write (iout,'(i3,1pe14.4)') (i,gana(i),i=1,nvar+20) !sp
12301       icall=1
12302       do i=1,nvar
12303         xi=x(i)
12304         x(i)=xi-0.5D0*aincr
12305         call var_to_geom(nvar,x)
12306         call chainbuild
12307         call etotal(energia1)
12308         etot1=energia1(0)
12309         x(i)=xi+0.5D0*aincr
12310         call var_to_geom(nvar,x)
12311         call chainbuild
12312         call etotal(energia2)
12313         etot2=energia2(0)
12314         gg(i)=(etot2-etot1)/aincr
12315         write (iout,*) i,etot1,etot2
12316         x(i)=xi
12317       enddo
12318       write (iout,'(/2a)')' Variable        Numerical       Analytical',&
12319           '     RelDiff*100% '
12320       do i=1,nvar
12321         if (i.le.nphi) then
12322           ii=i
12323           key = ' phi'
12324         else if (i.le.nphi+ntheta) then
12325           ii=i-nphi
12326           key=' theta'
12327         else if (i.le.nphi+ntheta+nside) then
12328            ii=i-(nphi+ntheta)
12329            key=' alpha'
12330         else
12331            ii=i-(nphi+ntheta+nside)
12332            key=' omega'
12333         endif
12334         write (iout,'(i3,a,i3,3(1pd16.6))') &
12335        i,key,ii,gg(i),gana(i),&
12336        100.0D0*dabs(gg(i)-gana(i))/(dabs(gana(i))+aincr)
12337       enddo
12338       return
12339       end subroutine check_eint
12340 !-----------------------------------------------------------------------------
12341 ! econstr_local.F
12342 !-----------------------------------------------------------------------------
12343       subroutine Econstr_back
12344 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
12345 !      implicit real*8 (a-h,o-z)
12346 !      include 'DIMENSIONS'
12347 !      include 'COMMON.CONTROL'
12348 !      include 'COMMON.VAR'
12349 !      include 'COMMON.MD'
12350       use MD_data
12351 !#ifndef LANG0
12352 !      include 'COMMON.LANGEVIN'
12353 !#else
12354 !      include 'COMMON.LANGEVIN.lang0'
12355 !#endif
12356 !      include 'COMMON.CHAIN'
12357 !      include 'COMMON.DERIV'
12358 !      include 'COMMON.GEO'
12359 !      include 'COMMON.LOCAL'
12360 !      include 'COMMON.INTERACT'
12361 !      include 'COMMON.IOUNITS'
12362 !      include 'COMMON.NAMES'
12363 !      include 'COMMON.TIME1'
12364       integer :: i,j,ii,k
12365       real(kind=8) :: utheta_i,dtheta_i,ugamma_i,dgamma_i,dxx,dyy,dzz
12366
12367       if(.not.allocated(utheta)) allocate(utheta(nfrag_back))
12368       if(.not.allocated(ugamma)) allocate(ugamma(nfrag_back))
12369       if(.not.allocated(uscdiff)) allocate(uscdiff(nfrag_back))
12370
12371       Uconst_back=0.0d0
12372       do i=1,nres
12373         dutheta(i)=0.0d0
12374         dugamma(i)=0.0d0
12375         do j=1,3
12376           duscdiff(j,i)=0.0d0
12377           duscdiffx(j,i)=0.0d0
12378         enddo
12379       enddo
12380       do i=1,nfrag_back
12381         ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
12382 !
12383 ! Deviations from theta angles
12384 !
12385         utheta_i=0.0d0
12386         do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset)
12387           dtheta_i=theta(j)-thetaref(j)
12388           utheta_i=utheta_i+0.5d0*dtheta_i*dtheta_i
12389           dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
12390         enddo
12391         utheta(i)=utheta_i/(ii-1)
12392 !
12393 ! Deviations from gamma angles
12394 !
12395         ugamma_i=0.0d0
12396         do j=ifrag_back(1,i,iset)+3,ifrag_back(2,i,iset)
12397           dgamma_i=pinorm(phi(j)-phiref(j))
12398 !          write (iout,*) j,phi(j),phi(j)-phiref(j)
12399           ugamma_i=ugamma_i+0.5d0*dgamma_i*dgamma_i
12400           dugamma(j-3)=dugamma(j-3)+wfrag_back(2,i,iset)*dgamma_i/(ii-2)
12401 !          write (iout,*) i,j,dgamma_i,wfrag_back(2,i,iset),dugamma(j-3)
12402         enddo
12403         ugamma(i)=ugamma_i/(ii-2)
12404 !
12405 ! Deviations from local SC geometry
12406 !
12407         uscdiff(i)=0.0d0
12408         do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1
12409           dxx=xxtab(j)-xxref(j)
12410           dyy=yytab(j)-yyref(j)
12411           dzz=zztab(j)-zzref(j)
12412           uscdiff(i)=uscdiff(i)+dxx*dxx+dyy*dyy+dzz*dzz
12413           do k=1,3
12414             duscdiff(k,j-1)=duscdiff(k,j-1)+wfrag_back(3,i,iset)* &
12415              (dXX_C1tab(k,j)*dxx+dYY_C1tab(k,j)*dyy+dZZ_C1tab(k,j)*dzz)/ &
12416              (ii-1)
12417             duscdiff(k,j)=duscdiff(k,j)+wfrag_back(3,i,iset)* &
12418              (dXX_Ctab(k,j)*dxx+dYY_Ctab(k,j)*dyy+dZZ_Ctab(k,j)*dzz)/ &
12419              (ii-1)
12420             duscdiffx(k,j)=duscdiffx(k,j)+wfrag_back(3,i,iset)* &
12421            (dXX_XYZtab(k,j)*dxx+dYY_XYZtab(k,j)*dyy+dZZ_XYZtab(k,j)*dzz) &
12422             /(ii-1)
12423           enddo
12424 !          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
12425 !     &      xxref(j),yyref(j),zzref(j)
12426         enddo
12427         uscdiff(i)=0.5d0*uscdiff(i)/(ii-1)
12428 !        write (iout,*) i," uscdiff",uscdiff(i)
12429 !
12430 ! Put together deviations from local geometry
12431 !
12432         Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+ &
12433           wfrag_back(2,i,iset)*ugamma(i)+wfrag_back(3,i,iset)*uscdiff(i)
12434 !        write(iout,*) "i",i," utheta",utheta(i)," ugamma",ugamma(i),
12435 !     &   " uconst_back",uconst_back
12436         utheta(i)=dsqrt(utheta(i))
12437         ugamma(i)=dsqrt(ugamma(i))
12438         uscdiff(i)=dsqrt(uscdiff(i))
12439       enddo
12440       return
12441       end subroutine Econstr_back
12442 !-----------------------------------------------------------------------------
12443 ! energy_p_new-sep_barrier.F
12444 !-----------------------------------------------------------------------------
12445       real(kind=8) function sscale(r)
12446 !      include "COMMON.SPLITELE"
12447       real(kind=8) :: r,gamm
12448       if(r.lt.r_cut-rlamb) then
12449         sscale=1.0d0
12450       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12451         gamm=(r-(r_cut-rlamb))/rlamb
12452         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12453       else
12454         sscale=0d0
12455       endif
12456       return
12457       end function sscale
12458       real(kind=8) function sscale_grad(r)
12459 !      include "COMMON.SPLITELE"
12460       real(kind=8) :: r,gamm
12461       if(r.lt.r_cut-rlamb) then
12462         sscale_grad=0.0d0
12463       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
12464         gamm=(r-(r_cut-rlamb))/rlamb
12465         sscale_grad=gamm*(6*gamm-6.0d0)/rlamb
12466       else
12467         sscale_grad=0d0
12468       endif
12469       return
12470       end function sscale_grad
12471
12472 !!!!!!!!!! PBCSCALE
12473       real(kind=8) function sscale_ele(r)
12474 !      include "COMMON.SPLITELE"
12475       real(kind=8) :: r,gamm
12476       if(r.lt.r_cut_ele-rlamb_ele) then
12477         sscale_ele=1.0d0
12478       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12479         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12480         sscale_ele=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12481       else
12482         sscale_ele=0d0
12483       endif
12484       return
12485       end function sscale_ele
12486
12487       real(kind=8)  function sscagrad_ele(r)
12488       real(kind=8) :: r,gamm
12489 !      include "COMMON.SPLITELE"
12490       if(r.lt.r_cut_ele-rlamb_ele) then
12491         sscagrad_ele=0.0d0
12492       else if(r.le.r_cut_ele.and.r.ge.r_cut_ele-rlamb_ele) then
12493         gamm=(r-(r_cut_ele-rlamb_ele))/rlamb_ele
12494         sscagrad_ele=gamm*(6*gamm-6.0d0)/rlamb_ele
12495       else
12496         sscagrad_ele=0.0d0
12497       endif
12498       return
12499       end function sscagrad_ele
12500       real(kind=8) function sscalelip(r)
12501       real(kind=8) r,gamm
12502         sscalelip=1.0d0+r*r*(2.0d0*r-3.0d0)
12503       return
12504       end function sscalelip
12505 !C-----------------------------------------------------------------------
12506       real(kind=8) function sscagradlip(r)
12507       real(kind=8) r,gamm
12508         sscagradlip=r*(6.0d0*r-6.0d0)
12509       return
12510       end function sscagradlip
12511
12512 !!!!!!!!!!!!!!!
12513 !-----------------------------------------------------------------------------
12514       subroutine elj_long(evdw)
12515 !
12516 ! This subroutine calculates the interaction energy of nonbonded side chains
12517 ! assuming the LJ potential of interaction.
12518 !
12519 !      implicit real*8 (a-h,o-z)
12520 !      include 'DIMENSIONS'
12521 !      include 'COMMON.GEO'
12522 !      include 'COMMON.VAR'
12523 !      include 'COMMON.LOCAL'
12524 !      include 'COMMON.CHAIN'
12525 !      include 'COMMON.DERIV'
12526 !      include 'COMMON.INTERACT'
12527 !      include 'COMMON.TORSION'
12528 !      include 'COMMON.SBRIDGE'
12529 !      include 'COMMON.NAMES'
12530 !      include 'COMMON.IOUNITS'
12531 !      include 'COMMON.CONTACTS'
12532       real(kind=8),parameter :: accur=1.0d-10
12533       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12534 !el local variables
12535       integer :: i,iint,j,k,itypi,itypi1,itypj
12536       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12537       real(kind=8) :: e1,e2,evdwij,evdw
12538 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12539       evdw=0.0D0
12540       do i=iatsc_s,iatsc_e
12541         itypi=itype(i,1)
12542         if (itypi.eq.ntyp1) cycle
12543         itypi1=itype(i+1,1)
12544         xi=c(1,nres+i)
12545         yi=c(2,nres+i)
12546         zi=c(3,nres+i)
12547 !
12548 ! Calculate SC interaction energy.
12549 !
12550         do iint=1,nint_gr(i)
12551 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12552 !d   &                  'iend=',iend(i,iint)
12553           do j=istart(i,iint),iend(i,iint)
12554             itypj=itype(j,1)
12555             if (itypj.eq.ntyp1) cycle
12556             xj=c(1,nres+j)-xi
12557             yj=c(2,nres+j)-yi
12558             zj=c(3,nres+j)-zi
12559             rij=xj*xj+yj*yj+zj*zj
12560             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12561             if (sss.lt.1.0d0) then
12562               rrij=1.0D0/rij
12563               eps0ij=eps(itypi,itypj)
12564               fac=rrij**expon2
12565               e1=fac*fac*aa_aq(itypi,itypj)
12566               e2=fac*bb_aq(itypi,itypj)
12567               evdwij=e1+e2
12568               evdw=evdw+(1.0d0-sss)*evdwij
12569 !
12570 ! Calculate the components of the gradient in DC and X
12571 !
12572               fac=-rrij*(e1+evdwij)*(1.0d0-sss)
12573               gg(1)=xj*fac
12574               gg(2)=yj*fac
12575               gg(3)=zj*fac
12576               do k=1,3
12577                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12578                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12579                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12580                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12581               enddo
12582             endif
12583           enddo      ! j
12584         enddo        ! iint
12585       enddo          ! i
12586       do i=1,nct
12587         do j=1,3
12588           gvdwc(j,i)=expon*gvdwc(j,i)
12589           gvdwx(j,i)=expon*gvdwx(j,i)
12590         enddo
12591       enddo
12592 !******************************************************************************
12593 !
12594 !                              N O T E !!!
12595 !
12596 ! To save time, the factor of EXPON has been extracted from ALL components
12597 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12598 ! use!
12599 !
12600 !******************************************************************************
12601       return
12602       end subroutine elj_long
12603 !-----------------------------------------------------------------------------
12604       subroutine elj_short(evdw)
12605 !
12606 ! This subroutine calculates the interaction energy of nonbonded side chains
12607 ! assuming the LJ potential of interaction.
12608 !
12609 !      implicit real*8 (a-h,o-z)
12610 !      include 'DIMENSIONS'
12611 !      include 'COMMON.GEO'
12612 !      include 'COMMON.VAR'
12613 !      include 'COMMON.LOCAL'
12614 !      include 'COMMON.CHAIN'
12615 !      include 'COMMON.DERIV'
12616 !      include 'COMMON.INTERACT'
12617 !      include 'COMMON.TORSION'
12618 !      include 'COMMON.SBRIDGE'
12619 !      include 'COMMON.NAMES'
12620 !      include 'COMMON.IOUNITS'
12621 !      include 'COMMON.CONTACTS'
12622       real(kind=8),parameter :: accur=1.0d-10
12623       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12624 !el local variables
12625       integer :: i,iint,j,k,itypi,itypi1,itypj,num_conti
12626       real(kind=8) :: xi,yi,zi,xj,yj,zj,rij,sss,rrij,fac,eps0ij
12627       real(kind=8) :: e1,e2,evdwij,evdw
12628 !      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
12629       evdw=0.0D0
12630       do i=iatsc_s,iatsc_e
12631         itypi=itype(i,1)
12632         if (itypi.eq.ntyp1) cycle
12633         itypi1=itype(i+1,1)
12634         xi=c(1,nres+i)
12635         yi=c(2,nres+i)
12636         zi=c(3,nres+i)
12637 ! Change 12/1/95
12638         num_conti=0
12639 !
12640 ! Calculate SC interaction energy.
12641 !
12642         do iint=1,nint_gr(i)
12643 !d        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
12644 !d   &                  'iend=',iend(i,iint)
12645           do j=istart(i,iint),iend(i,iint)
12646             itypj=itype(j,1)
12647             if (itypj.eq.ntyp1) cycle
12648             xj=c(1,nres+j)-xi
12649             yj=c(2,nres+j)-yi
12650             zj=c(3,nres+j)-zi
12651 ! Change 12/1/95 to calculate four-body interactions
12652             rij=xj*xj+yj*yj+zj*zj
12653             sss=sscale(dsqrt(rij)/sigma(itypi,itypj))
12654             if (sss.gt.0.0d0) then
12655               rrij=1.0D0/rij
12656               eps0ij=eps(itypi,itypj)
12657               fac=rrij**expon2
12658               e1=fac*fac*aa_aq(itypi,itypj)
12659               e2=fac*bb_aq(itypi,itypj)
12660               evdwij=e1+e2
12661               evdw=evdw+sss*evdwij
12662 !
12663 ! Calculate the components of the gradient in DC and X
12664 !
12665               fac=-rrij*(e1+evdwij)*sss
12666               gg(1)=xj*fac
12667               gg(2)=yj*fac
12668               gg(3)=zj*fac
12669               do k=1,3
12670                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12671                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12672                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12673                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12674               enddo
12675             endif
12676           enddo      ! j
12677         enddo        ! iint
12678       enddo          ! i
12679       do i=1,nct
12680         do j=1,3
12681           gvdwc(j,i)=expon*gvdwc(j,i)
12682           gvdwx(j,i)=expon*gvdwx(j,i)
12683         enddo
12684       enddo
12685 !******************************************************************************
12686 !
12687 !                              N O T E !!!
12688 !
12689 ! To save time, the factor of EXPON has been extracted from ALL components
12690 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
12691 ! use!
12692 !
12693 !******************************************************************************
12694       return
12695       end subroutine elj_short
12696 !-----------------------------------------------------------------------------
12697       subroutine eljk_long(evdw)
12698 !
12699 ! This subroutine calculates the interaction energy of nonbonded side chains
12700 ! assuming the LJK potential of interaction.
12701 !
12702 !      implicit real*8 (a-h,o-z)
12703 !      include 'DIMENSIONS'
12704 !      include 'COMMON.GEO'
12705 !      include 'COMMON.VAR'
12706 !      include 'COMMON.LOCAL'
12707 !      include 'COMMON.CHAIN'
12708 !      include 'COMMON.DERIV'
12709 !      include 'COMMON.INTERACT'
12710 !      include 'COMMON.IOUNITS'
12711 !      include 'COMMON.NAMES'
12712       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12713       logical :: scheck
12714 !el local variables
12715       integer :: i,iint,j,k,itypi,itypi1,itypj
12716       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12717                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12718 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12719       evdw=0.0D0
12720       do i=iatsc_s,iatsc_e
12721         itypi=itype(i,1)
12722         if (itypi.eq.ntyp1) cycle
12723         itypi1=itype(i+1,1)
12724         xi=c(1,nres+i)
12725         yi=c(2,nres+i)
12726         zi=c(3,nres+i)
12727 !
12728 ! Calculate SC interaction energy.
12729 !
12730         do iint=1,nint_gr(i)
12731           do j=istart(i,iint),iend(i,iint)
12732             itypj=itype(j,1)
12733             if (itypj.eq.ntyp1) cycle
12734             xj=c(1,nres+j)-xi
12735             yj=c(2,nres+j)-yi
12736             zj=c(3,nres+j)-zi
12737             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12738             fac_augm=rrij**expon
12739             e_augm=augm(itypi,itypj)*fac_augm
12740             r_inv_ij=dsqrt(rrij)
12741             rij=1.0D0/r_inv_ij
12742             sss=sscale(rij/sigma(itypi,itypj))
12743             if (sss.lt.1.0d0) then
12744               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12745               fac=r_shift_inv**expon
12746               e1=fac*fac*aa_aq(itypi,itypj)
12747               e2=fac*bb_aq(itypi,itypj)
12748               evdwij=e_augm+e1+e2
12749 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12750 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12751 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12752 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12753 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12754 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12755 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12756               evdw=evdw+(1.0d0-sss)*evdwij
12757 !
12758 ! Calculate the components of the gradient in DC and X
12759 !
12760               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12761               fac=fac*(1.0d0-sss)
12762               gg(1)=xj*fac
12763               gg(2)=yj*fac
12764               gg(3)=zj*fac
12765               do k=1,3
12766                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12767                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12768                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12769                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12770               enddo
12771             endif
12772           enddo      ! j
12773         enddo        ! iint
12774       enddo          ! i
12775       do i=1,nct
12776         do j=1,3
12777           gvdwc(j,i)=expon*gvdwc(j,i)
12778           gvdwx(j,i)=expon*gvdwx(j,i)
12779         enddo
12780       enddo
12781       return
12782       end subroutine eljk_long
12783 !-----------------------------------------------------------------------------
12784       subroutine eljk_short(evdw)
12785 !
12786 ! This subroutine calculates the interaction energy of nonbonded side chains
12787 ! assuming the LJK potential of interaction.
12788 !
12789 !      implicit real*8 (a-h,o-z)
12790 !      include 'DIMENSIONS'
12791 !      include 'COMMON.GEO'
12792 !      include 'COMMON.VAR'
12793 !      include 'COMMON.LOCAL'
12794 !      include 'COMMON.CHAIN'
12795 !      include 'COMMON.DERIV'
12796 !      include 'COMMON.INTERACT'
12797 !      include 'COMMON.IOUNITS'
12798 !      include 'COMMON.NAMES'
12799       real(kind=8),dimension(3) :: gg,gg_lipi,gg_lipj
12800       logical :: scheck
12801 !el local variables
12802       integer :: i,iint,j,k,itypi,itypi1,itypj
12803       real(kind=8) :: rrij,r_inv_ij,xj,yj,zj,xi,yi,zi,fac,evdw,&
12804                    fac_augm,e_augm,rij,sss,r_shift_inv,e1,e2,evdwij
12805 !     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
12806       evdw=0.0D0
12807       do i=iatsc_s,iatsc_e
12808         itypi=itype(i,1)
12809         if (itypi.eq.ntyp1) cycle
12810         itypi1=itype(i+1,1)
12811         xi=c(1,nres+i)
12812         yi=c(2,nres+i)
12813         zi=c(3,nres+i)
12814 !
12815 ! Calculate SC interaction energy.
12816 !
12817         do iint=1,nint_gr(i)
12818           do j=istart(i,iint),iend(i,iint)
12819             itypj=itype(j,1)
12820             if (itypj.eq.ntyp1) cycle
12821             xj=c(1,nres+j)-xi
12822             yj=c(2,nres+j)-yi
12823             zj=c(3,nres+j)-zi
12824             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12825             fac_augm=rrij**expon
12826             e_augm=augm(itypi,itypj)*fac_augm
12827             r_inv_ij=dsqrt(rrij)
12828             rij=1.0D0/r_inv_ij
12829             sss=sscale(rij/sigma(itypi,itypj))
12830             if (sss.gt.0.0d0) then
12831               r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
12832               fac=r_shift_inv**expon
12833               e1=fac*fac*aa_aq(itypi,itypj)
12834               e2=fac*bb_aq(itypi,itypj)
12835               evdwij=e_augm+e1+e2
12836 !d            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
12837 !d            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
12838 !d            write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
12839 !d   &          restyp(itypi,1),i,restyp(itypj,1),j,aa(itypi,itypj),
12840 !d   &          bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
12841 !d   &          sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
12842 !d   &          (c(k,i),k=1,3),(c(k,j),k=1,3)
12843               evdw=evdw+sss*evdwij
12844 !
12845 ! Calculate the components of the gradient in DC and X
12846 !
12847               fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
12848               fac=fac*sss
12849               gg(1)=xj*fac
12850               gg(2)=yj*fac
12851               gg(3)=zj*fac
12852               do k=1,3
12853                 gvdwx(k,i)=gvdwx(k,i)-gg(k)
12854                 gvdwx(k,j)=gvdwx(k,j)+gg(k)
12855                 gvdwc(k,i)=gvdwc(k,i)-gg(k)
12856                 gvdwc(k,j)=gvdwc(k,j)+gg(k)
12857               enddo
12858             endif
12859           enddo      ! j
12860         enddo        ! iint
12861       enddo          ! i
12862       do i=1,nct
12863         do j=1,3
12864           gvdwc(j,i)=expon*gvdwc(j,i)
12865           gvdwx(j,i)=expon*gvdwx(j,i)
12866         enddo
12867       enddo
12868       return
12869       end subroutine eljk_short
12870 !-----------------------------------------------------------------------------
12871       subroutine ebp_long(evdw)
12872 !
12873 ! This subroutine calculates the interaction energy of nonbonded side chains
12874 ! assuming the Berne-Pechukas potential of interaction.
12875 !
12876       use calc_data
12877 !      implicit real*8 (a-h,o-z)
12878 !      include 'DIMENSIONS'
12879 !      include 'COMMON.GEO'
12880 !      include 'COMMON.VAR'
12881 !      include 'COMMON.LOCAL'
12882 !      include 'COMMON.CHAIN'
12883 !      include 'COMMON.DERIV'
12884 !      include 'COMMON.NAMES'
12885 !      include 'COMMON.INTERACT'
12886 !      include 'COMMON.IOUNITS'
12887 !      include 'COMMON.CALC'
12888       use comm_srutu
12889 !el      integer :: icall
12890 !el      common /srutu/ icall
12891 !     double precision rrsave(maxdim)
12892       logical :: lprn
12893 !el local variables
12894       integer :: iint,itypi,itypi1,itypj
12895       real(kind=8) :: rrij,xi,yi,zi,fac
12896       real(kind=8) :: sss,e1,e2,evdw,sigm,epsi
12897       evdw=0.0D0
12898 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
12899       evdw=0.0D0
12900 !     if (icall.eq.0) then
12901 !       lprn=.true.
12902 !     else
12903         lprn=.false.
12904 !     endif
12905 !el      ind=0
12906       do i=iatsc_s,iatsc_e
12907         itypi=itype(i,1)
12908         if (itypi.eq.ntyp1) cycle
12909         itypi1=itype(i+1,1)
12910         xi=c(1,nres+i)
12911         yi=c(2,nres+i)
12912         zi=c(3,nres+i)
12913         dxi=dc_norm(1,nres+i)
12914         dyi=dc_norm(2,nres+i)
12915         dzi=dc_norm(3,nres+i)
12916 !        dsci_inv=dsc_inv(itypi)
12917         dsci_inv=vbld_inv(i+nres)
12918 !
12919 ! Calculate SC interaction energy.
12920 !
12921         do iint=1,nint_gr(i)
12922           do j=istart(i,iint),iend(i,iint)
12923 !el            ind=ind+1
12924             itypj=itype(j,1)
12925             if (itypj.eq.ntyp1) cycle
12926 !            dscj_inv=dsc_inv(itypj)
12927             dscj_inv=vbld_inv(j+nres)
12928             chi1=chi(itypi,itypj)
12929             chi2=chi(itypj,itypi)
12930             chi12=chi1*chi2
12931             chip1=chip(itypi)
12932             chip2=chip(itypj)
12933             chip12=chip1*chip2
12934             alf1=alp(itypi)
12935             alf2=alp(itypj)
12936             alf12=0.5D0*(alf1+alf2)
12937             xj=c(1,nres+j)-xi
12938             yj=c(2,nres+j)-yi
12939             zj=c(3,nres+j)-zi
12940             dxj=dc_norm(1,nres+j)
12941             dyj=dc_norm(2,nres+j)
12942             dzj=dc_norm(3,nres+j)
12943             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
12944             rij=dsqrt(rrij)
12945             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
12946
12947             if (sss.lt.1.0d0) then
12948
12949 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
12950               call sc_angular
12951 ! Calculate whole angle-dependent part of epsilon and contributions
12952 ! to its derivatives
12953               fac=(rrij*sigsq)**expon2
12954               e1=fac*fac*aa_aq(itypi,itypj)
12955               e2=fac*bb_aq(itypi,itypj)
12956               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
12957               eps2der=evdwij*eps3rt
12958               eps3der=evdwij*eps2rt
12959               evdwij=evdwij*eps2rt*eps3rt
12960               evdw=evdw+evdwij*(1.0d0-sss)
12961               if (lprn) then
12962               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
12963               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
12964 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
12965 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
12966 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
12967 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
12968 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
12969 !d     &          evdwij
12970               endif
12971 ! Calculate gradient components.
12972               e1=e1*eps1*eps2rt**2*eps3rt**2
12973               fac=-expon*(e1+evdwij)
12974               sigder=fac/sigsq
12975               fac=rrij*fac
12976 ! Calculate radial part of the gradient
12977               gg(1)=xj*fac
12978               gg(2)=yj*fac
12979               gg(3)=zj*fac
12980 ! Calculate the angular part of the gradient and sum add the contributions
12981 ! to the appropriate components of the Cartesian gradient.
12982               call sc_grad_scale(1.0d0-sss)
12983             endif
12984           enddo      ! j
12985         enddo        ! iint
12986       enddo          ! i
12987 !     stop
12988       return
12989       end subroutine ebp_long
12990 !-----------------------------------------------------------------------------
12991       subroutine ebp_short(evdw)
12992 !
12993 ! This subroutine calculates the interaction energy of nonbonded side chains
12994 ! assuming the Berne-Pechukas potential of interaction.
12995 !
12996       use calc_data
12997 !      implicit real*8 (a-h,o-z)
12998 !      include 'DIMENSIONS'
12999 !      include 'COMMON.GEO'
13000 !      include 'COMMON.VAR'
13001 !      include 'COMMON.LOCAL'
13002 !      include 'COMMON.CHAIN'
13003 !      include 'COMMON.DERIV'
13004 !      include 'COMMON.NAMES'
13005 !      include 'COMMON.INTERACT'
13006 !      include 'COMMON.IOUNITS'
13007 !      include 'COMMON.CALC'
13008       use comm_srutu
13009 !el      integer :: icall
13010 !el      common /srutu/ icall
13011 !     double precision rrsave(maxdim)
13012       logical :: lprn
13013 !el local variables
13014       integer :: iint,itypi,itypi1,itypj
13015       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi
13016       real(kind=8) :: sss,e1,e2,evdw
13017       evdw=0.0D0
13018 !     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
13019       evdw=0.0D0
13020 !     if (icall.eq.0) then
13021 !       lprn=.true.
13022 !     else
13023         lprn=.false.
13024 !     endif
13025 !el      ind=0
13026       do i=iatsc_s,iatsc_e
13027         itypi=itype(i,1)
13028         if (itypi.eq.ntyp1) cycle
13029         itypi1=itype(i+1,1)
13030         xi=c(1,nres+i)
13031         yi=c(2,nres+i)
13032         zi=c(3,nres+i)
13033         dxi=dc_norm(1,nres+i)
13034         dyi=dc_norm(2,nres+i)
13035         dzi=dc_norm(3,nres+i)
13036 !        dsci_inv=dsc_inv(itypi)
13037         dsci_inv=vbld_inv(i+nres)
13038 !
13039 ! Calculate SC interaction energy.
13040 !
13041         do iint=1,nint_gr(i)
13042           do j=istart(i,iint),iend(i,iint)
13043 !el            ind=ind+1
13044             itypj=itype(j,1)
13045             if (itypj.eq.ntyp1) cycle
13046 !            dscj_inv=dsc_inv(itypj)
13047             dscj_inv=vbld_inv(j+nres)
13048             chi1=chi(itypi,itypj)
13049             chi2=chi(itypj,itypi)
13050             chi12=chi1*chi2
13051             chip1=chip(itypi)
13052             chip2=chip(itypj)
13053             chip12=chip1*chip2
13054             alf1=alp(itypi)
13055             alf2=alp(itypj)
13056             alf12=0.5D0*(alf1+alf2)
13057             xj=c(1,nres+j)-xi
13058             yj=c(2,nres+j)-yi
13059             zj=c(3,nres+j)-zi
13060             dxj=dc_norm(1,nres+j)
13061             dyj=dc_norm(2,nres+j)
13062             dzj=dc_norm(3,nres+j)
13063             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13064             rij=dsqrt(rrij)
13065             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13066
13067             if (sss.gt.0.0d0) then
13068
13069 ! Calculate the angle-dependent terms of energy & contributions to derivatives.
13070               call sc_angular
13071 ! Calculate whole angle-dependent part of epsilon and contributions
13072 ! to its derivatives
13073               fac=(rrij*sigsq)**expon2
13074               e1=fac*fac*aa_aq(itypi,itypj)
13075               e2=fac*bb_aq(itypi,itypj)
13076               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13077               eps2der=evdwij*eps3rt
13078               eps3der=evdwij*eps2rt
13079               evdwij=evdwij*eps2rt*eps3rt
13080               evdw=evdw+evdwij*sss
13081               if (lprn) then
13082               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13083               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13084 !d              write (iout,'(2(a3,i3,2x),15(0pf7.3))')
13085 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13086 !d     &          epsi,sigm,chi1,chi2,chip1,chip2,
13087 !d     &          eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
13088 !d     &          om1,om2,om12,1.0D0/dsqrt(rrij),
13089 !d     &          evdwij
13090               endif
13091 ! Calculate gradient components.
13092               e1=e1*eps1*eps2rt**2*eps3rt**2
13093               fac=-expon*(e1+evdwij)
13094               sigder=fac/sigsq
13095               fac=rrij*fac
13096 ! Calculate radial part of the gradient
13097               gg(1)=xj*fac
13098               gg(2)=yj*fac
13099               gg(3)=zj*fac
13100 ! Calculate the angular part of the gradient and sum add the contributions
13101 ! to the appropriate components of the Cartesian gradient.
13102               call sc_grad_scale(sss)
13103             endif
13104           enddo      ! j
13105         enddo        ! iint
13106       enddo          ! i
13107 !     stop
13108       return
13109       end subroutine ebp_short
13110 !-----------------------------------------------------------------------------
13111       subroutine egb_long(evdw)
13112 !
13113 ! This subroutine calculates the interaction energy of nonbonded side chains
13114 ! assuming the Gay-Berne potential of interaction.
13115 !
13116       use calc_data
13117 !      implicit real*8 (a-h,o-z)
13118 !      include 'DIMENSIONS'
13119 !      include 'COMMON.GEO'
13120 !      include 'COMMON.VAR'
13121 !      include 'COMMON.LOCAL'
13122 !      include 'COMMON.CHAIN'
13123 !      include 'COMMON.DERIV'
13124 !      include 'COMMON.NAMES'
13125 !      include 'COMMON.INTERACT'
13126 !      include 'COMMON.IOUNITS'
13127 !      include 'COMMON.CALC'
13128 !      include 'COMMON.CONTROL'
13129       logical :: lprn
13130 !el local variables
13131       integer :: iint,itypi,itypi1,itypj,subchap
13132       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig,sig0ij,rij_shift
13133       real(kind=8) :: sss,e1,e2,evdw,sss_grad
13134       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13135                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13136                     ssgradlipi,ssgradlipj
13137
13138
13139       evdw=0.0D0
13140 !cccc      energy_dec=.false.
13141 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13142       evdw=0.0D0
13143       lprn=.false.
13144 !     if (icall.eq.0) lprn=.false.
13145 !el      ind=0
13146       do i=iatsc_s,iatsc_e
13147         itypi=itype(i,1)
13148         if (itypi.eq.ntyp1) cycle
13149         itypi1=itype(i+1,1)
13150         xi=c(1,nres+i)
13151         yi=c(2,nres+i)
13152         zi=c(3,nres+i)
13153           xi=mod(xi,boxxsize)
13154           if (xi.lt.0) xi=xi+boxxsize
13155           yi=mod(yi,boxysize)
13156           if (yi.lt.0) yi=yi+boxysize
13157           zi=mod(zi,boxzsize)
13158           if (zi.lt.0) zi=zi+boxzsize
13159        if ((zi.gt.bordlipbot)    &
13160         .and.(zi.lt.bordliptop)) then
13161 !C the energy transfer exist
13162         if (zi.lt.buflipbot) then
13163 !C what fraction I am in
13164          fracinbuf=1.0d0-    &
13165              ((zi-bordlipbot)/lipbufthick)
13166 !C lipbufthick is thickenes of lipid buffore
13167          sslipi=sscalelip(fracinbuf)
13168          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13169         elseif (zi.gt.bufliptop) then
13170          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13171          sslipi=sscalelip(fracinbuf)
13172          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13173         else
13174          sslipi=1.0d0
13175          ssgradlipi=0.0
13176         endif
13177        else
13178          sslipi=0.0d0
13179          ssgradlipi=0.0
13180        endif
13181
13182         dxi=dc_norm(1,nres+i)
13183         dyi=dc_norm(2,nres+i)
13184         dzi=dc_norm(3,nres+i)
13185 !        dsci_inv=dsc_inv(itypi)
13186         dsci_inv=vbld_inv(i+nres)
13187 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13188 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13189 !
13190 ! Calculate SC interaction energy.
13191 !
13192         do iint=1,nint_gr(i)
13193           do j=istart(i,iint),iend(i,iint)
13194             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13195 !              call dyn_ssbond_ene(i,j,evdwij)
13196 !              evdw=evdw+evdwij
13197 !              if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13198 !                              'evdw',i,j,evdwij,' ss'
13199 !              if (energy_dec) write (iout,*) &
13200 !                              'evdw',i,j,evdwij,' ss'
13201 !             do k=j+1,iend(i,iint)
13202 !C search over all next residues
13203 !              if (dyn_ss_mask(k)) then
13204 !C check if they are cysteins
13205 !C              write(iout,*) 'k=',k
13206
13207 !c              write(iout,*) "PRZED TRI", evdwij
13208 !               evdwij_przed_tri=evdwij
13209 !              call triple_ssbond_ene(i,j,k,evdwij)
13210 !c               if(evdwij_przed_tri.ne.evdwij) then
13211 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13212 !c               endif
13213
13214 !c              write(iout,*) "PO TRI", evdwij
13215 !C call the energy function that removes the artifical triple disulfide
13216 !C bond the soubroutine is located in ssMD.F
13217 !              evdw=evdw+evdwij
13218               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13219                             'evdw',i,j,evdwij,'tss'
13220 !              endif!dyn_ss_mask(k)
13221 !             enddo! k
13222
13223             ELSE
13224 !el            ind=ind+1
13225             itypj=itype(j,1)
13226             if (itypj.eq.ntyp1) cycle
13227 !            dscj_inv=dsc_inv(itypj)
13228             dscj_inv=vbld_inv(j+nres)
13229 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13230 !     &       1.0d0/vbld(j+nres)
13231 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13232             sig0ij=sigma(itypi,itypj)
13233             chi1=chi(itypi,itypj)
13234             chi2=chi(itypj,itypi)
13235             chi12=chi1*chi2
13236             chip1=chip(itypi)
13237             chip2=chip(itypj)
13238             chip12=chip1*chip2
13239             alf1=alp(itypi)
13240             alf2=alp(itypj)
13241             alf12=0.5D0*(alf1+alf2)
13242             xj=c(1,nres+j)
13243             yj=c(2,nres+j)
13244             zj=c(3,nres+j)
13245 ! Searching for nearest neighbour
13246           xj=mod(xj,boxxsize)
13247           if (xj.lt.0) xj=xj+boxxsize
13248           yj=mod(yj,boxysize)
13249           if (yj.lt.0) yj=yj+boxysize
13250           zj=mod(zj,boxzsize)
13251           if (zj.lt.0) zj=zj+boxzsize
13252        if ((zj.gt.bordlipbot)   &
13253       .and.(zj.lt.bordliptop)) then
13254 !C the energy transfer exist
13255         if (zj.lt.buflipbot) then
13256 !C what fraction I am in
13257          fracinbuf=1.0d0-  &
13258              ((zj-bordlipbot)/lipbufthick)
13259 !C lipbufthick is thickenes of lipid buffore
13260          sslipj=sscalelip(fracinbuf)
13261          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13262         elseif (zj.gt.bufliptop) then
13263          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13264          sslipj=sscalelip(fracinbuf)
13265          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13266         else
13267          sslipj=1.0d0
13268          ssgradlipj=0.0
13269         endif
13270        else
13271          sslipj=0.0d0
13272          ssgradlipj=0.0
13273        endif
13274       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13275        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13276       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13277        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13278
13279           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13280           xj_safe=xj
13281           yj_safe=yj
13282           zj_safe=zj
13283           subchap=0
13284           do xshift=-1,1
13285           do yshift=-1,1
13286           do zshift=-1,1
13287           xj=xj_safe+xshift*boxxsize
13288           yj=yj_safe+yshift*boxysize
13289           zj=zj_safe+zshift*boxzsize
13290           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13291           if(dist_temp.lt.dist_init) then
13292             dist_init=dist_temp
13293             xj_temp=xj
13294             yj_temp=yj
13295             zj_temp=zj
13296             subchap=1
13297           endif
13298           enddo
13299           enddo
13300           enddo
13301           if (subchap.eq.1) then
13302           xj=xj_temp-xi
13303           yj=yj_temp-yi
13304           zj=zj_temp-zi
13305           else
13306           xj=xj_safe-xi
13307           yj=yj_safe-yi
13308           zj=zj_safe-zi
13309           endif
13310
13311             dxj=dc_norm(1,nres+j)
13312             dyj=dc_norm(2,nres+j)
13313             dzj=dc_norm(3,nres+j)
13314             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13315             rij=dsqrt(rrij)
13316             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13317             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13318             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13319             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13320             if (sss_ele_cut.le.0.0) cycle
13321             if (sss.lt.1.0d0) then
13322
13323 ! Calculate angle-dependent terms of energy and contributions to their
13324 ! derivatives.
13325               call sc_angular
13326               sigsq=1.0D0/sigsq
13327               sig=sig0ij*dsqrt(sigsq)
13328               rij_shift=1.0D0/rij-sig+sig0ij
13329 ! for diagnostics; uncomment
13330 !              rij_shift=1.2*sig0ij
13331 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13332               if (rij_shift.le.0.0D0) then
13333                 evdw=1.0D20
13334 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13335 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13336 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13337                 return
13338               endif
13339               sigder=-sig*sigsq
13340 !---------------------------------------------------------------
13341               rij_shift=1.0D0/rij_shift
13342               fac=rij_shift**expon
13343               e1=fac*fac*aa
13344               e2=fac*bb
13345               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13346               eps2der=evdwij*eps3rt
13347               eps3der=evdwij*eps2rt
13348 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13349 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13350               evdwij=evdwij*eps2rt*eps3rt
13351               evdw=evdw+evdwij*(1.0d0-sss)*sss_ele_cut
13352               if (lprn) then
13353               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13354               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13355               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13356                 restyp(itypi,1),i,restyp(itypj,1),j,&
13357                 epsi,sigm,chi1,chi2,chip1,chip2,&
13358                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13359                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13360                 evdwij
13361               endif
13362
13363               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13364                               'evdw',i,j,evdwij
13365 !              if (energy_dec) write (iout,*) &
13366 !                              'evdw',i,j,evdwij,"egb_long"
13367
13368 ! Calculate gradient components.
13369               e1=e1*eps1*eps2rt**2*eps3rt**2
13370               fac=-expon*(e1+evdwij)*rij_shift
13371               sigder=fac*sigder
13372               fac=rij*fac
13373               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13374             /sigma(itypi,itypj)*rij-sss_grad/(1.0-sss)*rij  &
13375             /sigmaii(itypi,itypj))
13376 !              fac=0.0d0
13377 ! Calculate the radial part of the gradient
13378               gg(1)=xj*fac
13379               gg(2)=yj*fac
13380               gg(3)=zj*fac
13381 ! Calculate angular part of the gradient.
13382               call sc_grad_scale(1.0d0-sss)
13383             ENDIF    !mask_dyn_ss
13384             endif
13385           enddo      ! j
13386         enddo        ! iint
13387       enddo          ! i
13388 !      write (iout,*) "Number of loop steps in EGB:",ind
13389 !ccc      energy_dec=.false.
13390       return
13391       end subroutine egb_long
13392 !-----------------------------------------------------------------------------
13393       subroutine egb_short(evdw)
13394 !
13395 ! This subroutine calculates the interaction energy of nonbonded side chains
13396 ! assuming the Gay-Berne potential of interaction.
13397 !
13398       use calc_data
13399 !      implicit real*8 (a-h,o-z)
13400 !      include 'DIMENSIONS'
13401 !      include 'COMMON.GEO'
13402 !      include 'COMMON.VAR'
13403 !      include 'COMMON.LOCAL'
13404 !      include 'COMMON.CHAIN'
13405 !      include 'COMMON.DERIV'
13406 !      include 'COMMON.NAMES'
13407 !      include 'COMMON.INTERACT'
13408 !      include 'COMMON.IOUNITS'
13409 !      include 'COMMON.CALC'
13410 !      include 'COMMON.CONTROL'
13411       logical :: lprn
13412 !el local variables
13413       integer :: iint,itypi,itypi1,itypj,subchap
13414       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,sig0ij,sig
13415       real(kind=8) :: sss,e1,e2,evdw,rij_shift,sss_grad
13416       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
13417                     dist_temp, dist_init,aa,bb,fracinbuf,sslipi,sslipj,&
13418                     ssgradlipi,ssgradlipj
13419       evdw=0.0D0
13420 !cccc      energy_dec=.false.
13421 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13422       evdw=0.0D0
13423       lprn=.false.
13424 !     if (icall.eq.0) lprn=.false.
13425 !el      ind=0
13426       do i=iatsc_s,iatsc_e
13427         itypi=itype(i,1)
13428         if (itypi.eq.ntyp1) cycle
13429         itypi1=itype(i+1,1)
13430         xi=c(1,nres+i)
13431         yi=c(2,nres+i)
13432         zi=c(3,nres+i)
13433           xi=mod(xi,boxxsize)
13434           if (xi.lt.0) xi=xi+boxxsize
13435           yi=mod(yi,boxysize)
13436           if (yi.lt.0) yi=yi+boxysize
13437           zi=mod(zi,boxzsize)
13438           if (zi.lt.0) zi=zi+boxzsize
13439        if ((zi.gt.bordlipbot)    &
13440         .and.(zi.lt.bordliptop)) then
13441 !C the energy transfer exist
13442         if (zi.lt.buflipbot) then
13443 !C what fraction I am in
13444          fracinbuf=1.0d0-    &
13445              ((zi-bordlipbot)/lipbufthick)
13446 !C lipbufthick is thickenes of lipid buffore
13447          sslipi=sscalelip(fracinbuf)
13448          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
13449         elseif (zi.gt.bufliptop) then
13450          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
13451          sslipi=sscalelip(fracinbuf)
13452          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
13453         else
13454          sslipi=1.0d0
13455          ssgradlipi=0.0
13456         endif
13457        else
13458          sslipi=0.0d0
13459          ssgradlipi=0.0
13460        endif
13461
13462         dxi=dc_norm(1,nres+i)
13463         dyi=dc_norm(2,nres+i)
13464         dzi=dc_norm(3,nres+i)
13465 !        dsci_inv=dsc_inv(itypi)
13466         dsci_inv=vbld_inv(i+nres)
13467
13468         dxi=dc_norm(1,nres+i)
13469         dyi=dc_norm(2,nres+i)
13470         dzi=dc_norm(3,nres+i)
13471 !        dsci_inv=dsc_inv(itypi)
13472         dsci_inv=vbld_inv(i+nres)
13473 !        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
13474 !        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
13475 !
13476 ! Calculate SC interaction energy.
13477 !
13478         do iint=1,nint_gr(i)
13479           do j=istart(i,iint),iend(i,iint)
13480             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
13481               call dyn_ssbond_ene(i,j,evdwij)
13482               evdw=evdw+evdwij
13483               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13484                               'evdw',i,j,evdwij,' ss'
13485              do k=j+1,iend(i,iint)
13486 !C search over all next residues
13487               if (dyn_ss_mask(k)) then
13488 !C check if they are cysteins
13489 !C              write(iout,*) 'k=',k
13490
13491 !c              write(iout,*) "PRZED TRI", evdwij
13492 !               evdwij_przed_tri=evdwij
13493               call triple_ssbond_ene(i,j,k,evdwij)
13494 !c               if(evdwij_przed_tri.ne.evdwij) then
13495 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
13496 !c               endif
13497
13498 !c              write(iout,*) "PO TRI", evdwij
13499 !C call the energy function that removes the artifical triple disulfide
13500 !C bond the soubroutine is located in ssMD.F
13501               evdw=evdw+evdwij
13502               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
13503                             'evdw',i,j,evdwij,'tss'
13504               endif!dyn_ss_mask(k)
13505              enddo! k
13506
13507 !              if (energy_dec) write (iout,*) &
13508 !                              'evdw',i,j,evdwij,' ss'
13509             ELSE
13510 !el            ind=ind+1
13511             itypj=itype(j,1)
13512             if (itypj.eq.ntyp1) cycle
13513 !            dscj_inv=dsc_inv(itypj)
13514             dscj_inv=vbld_inv(j+nres)
13515 !            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
13516 !     &       1.0d0/vbld(j+nres)
13517 !            write (iout,*) "i",i," j", j," itype",itype(i,1),itype(j,1)
13518             sig0ij=sigma(itypi,itypj)
13519             chi1=chi(itypi,itypj)
13520             chi2=chi(itypj,itypi)
13521             chi12=chi1*chi2
13522             chip1=chip(itypi)
13523             chip2=chip(itypj)
13524             chip12=chip1*chip2
13525             alf1=alp(itypi)
13526             alf2=alp(itypj)
13527             alf12=0.5D0*(alf1+alf2)
13528 !            xj=c(1,nres+j)-xi
13529 !            yj=c(2,nres+j)-yi
13530 !            zj=c(3,nres+j)-zi
13531             xj=c(1,nres+j)
13532             yj=c(2,nres+j)
13533             zj=c(3,nres+j)
13534 ! Searching for nearest neighbour
13535           xj=mod(xj,boxxsize)
13536           if (xj.lt.0) xj=xj+boxxsize
13537           yj=mod(yj,boxysize)
13538           if (yj.lt.0) yj=yj+boxysize
13539           zj=mod(zj,boxzsize)
13540           if (zj.lt.0) zj=zj+boxzsize
13541        if ((zj.gt.bordlipbot)   &
13542       .and.(zj.lt.bordliptop)) then
13543 !C the energy transfer exist
13544         if (zj.lt.buflipbot) then
13545 !C what fraction I am in
13546          fracinbuf=1.0d0-  &
13547              ((zj-bordlipbot)/lipbufthick)
13548 !C lipbufthick is thickenes of lipid buffore
13549          sslipj=sscalelip(fracinbuf)
13550          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
13551         elseif (zj.gt.bufliptop) then
13552          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
13553          sslipj=sscalelip(fracinbuf)
13554          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
13555         else
13556          sslipj=1.0d0
13557          ssgradlipj=0.0
13558         endif
13559        else
13560          sslipj=0.0d0
13561          ssgradlipj=0.0
13562        endif
13563       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13564        +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13565       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0 &
13566        +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
13567
13568           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13569           xj_safe=xj
13570           yj_safe=yj
13571           zj_safe=zj
13572           subchap=0
13573
13574           do xshift=-1,1
13575           do yshift=-1,1
13576           do zshift=-1,1
13577           xj=xj_safe+xshift*boxxsize
13578           yj=yj_safe+yshift*boxysize
13579           zj=zj_safe+zshift*boxzsize
13580           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
13581           if(dist_temp.lt.dist_init) then
13582             dist_init=dist_temp
13583             xj_temp=xj
13584             yj_temp=yj
13585             zj_temp=zj
13586             subchap=1
13587           endif
13588           enddo
13589           enddo
13590           enddo
13591           if (subchap.eq.1) then
13592           xj=xj_temp-xi
13593           yj=yj_temp-yi
13594           zj=zj_temp-zi
13595           else
13596           xj=xj_safe-xi
13597           yj=yj_safe-yi
13598           zj=zj_safe-zi
13599           endif
13600
13601             dxj=dc_norm(1,nres+j)
13602             dyj=dc_norm(2,nres+j)
13603             dzj=dc_norm(3,nres+j)
13604             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13605             rij=dsqrt(rrij)
13606             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13607             sss_grad=sscale_grad(1.0d0/(rij*sigmaii(itypi,itypj)))
13608             sss_ele_cut=sscale_ele(1.0d0/(rij*sigma(itypi,itypj)))
13609             sss_ele_grad=sscagrad_ele(1.0d0/(rij*sigma(itypi,itypj)))
13610             if (sss_ele_cut.le.0.0) cycle
13611
13612             if (sss.gt.0.0d0) then
13613
13614 ! Calculate angle-dependent terms of energy and contributions to their
13615 ! derivatives.
13616               call sc_angular
13617               sigsq=1.0D0/sigsq
13618               sig=sig0ij*dsqrt(sigsq)
13619               rij_shift=1.0D0/rij-sig+sig0ij
13620 ! for diagnostics; uncomment
13621 !              rij_shift=1.2*sig0ij
13622 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13623               if (rij_shift.le.0.0D0) then
13624                 evdw=1.0D20
13625 !d                write (iout,'(2(a3,i3,2x),17(0pf7.3))')
13626 !d     &          restyp(itypi,1),i,restyp(itypj,1),j,
13627 !d     &          rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
13628                 return
13629               endif
13630               sigder=-sig*sigsq
13631 !---------------------------------------------------------------
13632               rij_shift=1.0D0/rij_shift
13633               fac=rij_shift**expon
13634               e1=fac*fac*aa
13635               e2=fac*bb
13636               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13637               eps2der=evdwij*eps3rt
13638               eps3der=evdwij*eps2rt
13639 !              write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
13640 !     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
13641               evdwij=evdwij*eps2rt*eps3rt
13642               evdw=evdw+evdwij*sss*sss_ele_cut
13643               if (lprn) then
13644               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13645               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13646               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13647                 restyp(itypi,1),i,restyp(itypj,1),j,&
13648                 epsi,sigm,chi1,chi2,chip1,chip2,&
13649                 eps1,eps2rt**2,eps3rt**2,sig,sig0ij,&
13650                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13651                 evdwij
13652               endif
13653
13654               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
13655                               'evdw',i,j,evdwij
13656 !              if (energy_dec) write (iout,*) &
13657 !                              'evdw',i,j,evdwij,"egb_short"
13658
13659 ! Calculate gradient components.
13660               e1=e1*eps1*eps2rt**2*eps3rt**2
13661               fac=-expon*(e1+evdwij)*rij_shift
13662               sigder=fac*sigder
13663               fac=rij*fac
13664               fac=fac+evdwij*(sss_ele_grad/sss_ele_cut&
13665             /sigma(itypi,itypj)*rij+sss_grad/sss*rij  &
13666             /sigmaii(itypi,itypj))
13667
13668 !              fac=0.0d0
13669 ! Calculate the radial part of the gradient
13670               gg(1)=xj*fac
13671               gg(2)=yj*fac
13672               gg(3)=zj*fac
13673 ! Calculate angular part of the gradient.
13674               call sc_grad_scale(sss)
13675             endif
13676           ENDIF !mask_dyn_ss
13677           enddo      ! j
13678         enddo        ! iint
13679       enddo          ! i
13680 !      write (iout,*) "Number of loop steps in EGB:",ind
13681 !ccc      energy_dec=.false.
13682       return
13683       end subroutine egb_short
13684 !-----------------------------------------------------------------------------
13685       subroutine egbv_long(evdw)
13686 !
13687 ! This subroutine calculates the interaction energy of nonbonded side chains
13688 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13689 !
13690       use calc_data
13691 !      implicit real*8 (a-h,o-z)
13692 !      include 'DIMENSIONS'
13693 !      include 'COMMON.GEO'
13694 !      include 'COMMON.VAR'
13695 !      include 'COMMON.LOCAL'
13696 !      include 'COMMON.CHAIN'
13697 !      include 'COMMON.DERIV'
13698 !      include 'COMMON.NAMES'
13699 !      include 'COMMON.INTERACT'
13700 !      include 'COMMON.IOUNITS'
13701 !      include 'COMMON.CALC'
13702       use comm_srutu
13703 !el      integer :: icall
13704 !el      common /srutu/ icall
13705       logical :: lprn
13706 !el local variables
13707       integer :: iint,itypi,itypi1,itypj
13708       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,r0ij,sig,sig0ij
13709       real(kind=8) :: sss,e1,e2,evdw,fac_augm,e_augm,rij_shift
13710       evdw=0.0D0
13711 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13712       evdw=0.0D0
13713       lprn=.false.
13714 !     if (icall.eq.0) lprn=.true.
13715 !el      ind=0
13716       do i=iatsc_s,iatsc_e
13717         itypi=itype(i,1)
13718         if (itypi.eq.ntyp1) cycle
13719         itypi1=itype(i+1,1)
13720         xi=c(1,nres+i)
13721         yi=c(2,nres+i)
13722         zi=c(3,nres+i)
13723         dxi=dc_norm(1,nres+i)
13724         dyi=dc_norm(2,nres+i)
13725         dzi=dc_norm(3,nres+i)
13726 !        dsci_inv=dsc_inv(itypi)
13727         dsci_inv=vbld_inv(i+nres)
13728 !
13729 ! Calculate SC interaction energy.
13730 !
13731         do iint=1,nint_gr(i)
13732           do j=istart(i,iint),iend(i,iint)
13733 !el            ind=ind+1
13734             itypj=itype(j,1)
13735             if (itypj.eq.ntyp1) cycle
13736 !            dscj_inv=dsc_inv(itypj)
13737             dscj_inv=vbld_inv(j+nres)
13738             sig0ij=sigma(itypi,itypj)
13739             r0ij=r0(itypi,itypj)
13740             chi1=chi(itypi,itypj)
13741             chi2=chi(itypj,itypi)
13742             chi12=chi1*chi2
13743             chip1=chip(itypi)
13744             chip2=chip(itypj)
13745             chip12=chip1*chip2
13746             alf1=alp(itypi)
13747             alf2=alp(itypj)
13748             alf12=0.5D0*(alf1+alf2)
13749             xj=c(1,nres+j)-xi
13750             yj=c(2,nres+j)-yi
13751             zj=c(3,nres+j)-zi
13752             dxj=dc_norm(1,nres+j)
13753             dyj=dc_norm(2,nres+j)
13754             dzj=dc_norm(3,nres+j)
13755             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13756             rij=dsqrt(rrij)
13757
13758             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13759
13760             if (sss.lt.1.0d0) then
13761
13762 ! Calculate angle-dependent terms of energy and contributions to their
13763 ! derivatives.
13764               call sc_angular
13765               sigsq=1.0D0/sigsq
13766               sig=sig0ij*dsqrt(sigsq)
13767               rij_shift=1.0D0/rij-sig+r0ij
13768 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13769               if (rij_shift.le.0.0D0) then
13770                 evdw=1.0D20
13771                 return
13772               endif
13773               sigder=-sig*sigsq
13774 !---------------------------------------------------------------
13775               rij_shift=1.0D0/rij_shift
13776               fac=rij_shift**expon
13777               e1=fac*fac*aa_aq(itypi,itypj)
13778               e2=fac*bb_aq(itypi,itypj)
13779               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13780               eps2der=evdwij*eps3rt
13781               eps3der=evdwij*eps2rt
13782               fac_augm=rrij**expon
13783               e_augm=augm(itypi,itypj)*fac_augm
13784               evdwij=evdwij*eps2rt*eps3rt
13785               evdw=evdw+(evdwij+e_augm)*(1.0d0-sss)
13786               if (lprn) then
13787               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13788               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13789               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13790                 restyp(itypi,1),i,restyp(itypj,1),j,&
13791                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13792                 chi1,chi2,chip1,chip2,&
13793                 eps1,eps2rt**2,eps3rt**2,&
13794                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13795                 evdwij+e_augm
13796               endif
13797 ! Calculate gradient components.
13798               e1=e1*eps1*eps2rt**2*eps3rt**2
13799               fac=-expon*(e1+evdwij)*rij_shift
13800               sigder=fac*sigder
13801               fac=rij*fac-2*expon*rrij*e_augm
13802 ! Calculate the radial part of the gradient
13803               gg(1)=xj*fac
13804               gg(2)=yj*fac
13805               gg(3)=zj*fac
13806 ! Calculate angular part of the gradient.
13807               call sc_grad_scale(1.0d0-sss)
13808             endif
13809           enddo      ! j
13810         enddo        ! iint
13811       enddo          ! i
13812       end subroutine egbv_long
13813 !-----------------------------------------------------------------------------
13814       subroutine egbv_short(evdw)
13815 !
13816 ! This subroutine calculates the interaction energy of nonbonded side chains
13817 ! assuming the Gay-Berne-Vorobjev potential of interaction.
13818 !
13819       use calc_data
13820 !      implicit real*8 (a-h,o-z)
13821 !      include 'DIMENSIONS'
13822 !      include 'COMMON.GEO'
13823 !      include 'COMMON.VAR'
13824 !      include 'COMMON.LOCAL'
13825 !      include 'COMMON.CHAIN'
13826 !      include 'COMMON.DERIV'
13827 !      include 'COMMON.NAMES'
13828 !      include 'COMMON.INTERACT'
13829 !      include 'COMMON.IOUNITS'
13830 !      include 'COMMON.CALC'
13831       use comm_srutu
13832 !el      integer :: icall
13833 !el      common /srutu/ icall
13834       logical :: lprn
13835 !el local variables
13836       integer :: iint,itypi,itypi1,itypj
13837       real(kind=8) :: rrij,xi,yi,zi,fac,sigm,epsi,rij_shift
13838       real(kind=8) :: sss,e1,e2,evdw,r0ij,sig,sig0ij,fac_augm,e_augm
13839       evdw=0.0D0
13840 !     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
13841       evdw=0.0D0
13842       lprn=.false.
13843 !     if (icall.eq.0) lprn=.true.
13844 !el      ind=0
13845       do i=iatsc_s,iatsc_e
13846         itypi=itype(i,1)
13847         if (itypi.eq.ntyp1) cycle
13848         itypi1=itype(i+1,1)
13849         xi=c(1,nres+i)
13850         yi=c(2,nres+i)
13851         zi=c(3,nres+i)
13852         dxi=dc_norm(1,nres+i)
13853         dyi=dc_norm(2,nres+i)
13854         dzi=dc_norm(3,nres+i)
13855 !        dsci_inv=dsc_inv(itypi)
13856         dsci_inv=vbld_inv(i+nres)
13857 !
13858 ! Calculate SC interaction energy.
13859 !
13860         do iint=1,nint_gr(i)
13861           do j=istart(i,iint),iend(i,iint)
13862 !el            ind=ind+1
13863             itypj=itype(j,1)
13864             if (itypj.eq.ntyp1) cycle
13865 !            dscj_inv=dsc_inv(itypj)
13866             dscj_inv=vbld_inv(j+nres)
13867             sig0ij=sigma(itypi,itypj)
13868             r0ij=r0(itypi,itypj)
13869             chi1=chi(itypi,itypj)
13870             chi2=chi(itypj,itypi)
13871             chi12=chi1*chi2
13872             chip1=chip(itypi)
13873             chip2=chip(itypj)
13874             chip12=chip1*chip2
13875             alf1=alp(itypi)
13876             alf2=alp(itypj)
13877             alf12=0.5D0*(alf1+alf2)
13878             xj=c(1,nres+j)-xi
13879             yj=c(2,nres+j)-yi
13880             zj=c(3,nres+j)-zi
13881             dxj=dc_norm(1,nres+j)
13882             dyj=dc_norm(2,nres+j)
13883             dzj=dc_norm(3,nres+j)
13884             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
13885             rij=dsqrt(rrij)
13886
13887             sss=sscale(1.0d0/(rij*sigmaii(itypi,itypj)))
13888
13889             if (sss.gt.0.0d0) then
13890
13891 ! Calculate angle-dependent terms of energy and contributions to their
13892 ! derivatives.
13893               call sc_angular
13894               sigsq=1.0D0/sigsq
13895               sig=sig0ij*dsqrt(sigsq)
13896               rij_shift=1.0D0/rij-sig+r0ij
13897 ! I hate to put IF's in the loops, but here don't have another choice!!!!
13898               if (rij_shift.le.0.0D0) then
13899                 evdw=1.0D20
13900                 return
13901               endif
13902               sigder=-sig*sigsq
13903 !---------------------------------------------------------------
13904               rij_shift=1.0D0/rij_shift
13905               fac=rij_shift**expon
13906               e1=fac*fac*aa_aq(itypi,itypj)
13907               e2=fac*bb_aq(itypi,itypj)
13908               evdwij=eps1*eps2rt*eps3rt*(e1+e2)
13909               eps2der=evdwij*eps3rt
13910               eps3der=evdwij*eps2rt
13911               fac_augm=rrij**expon
13912               e_augm=augm(itypi,itypj)*fac_augm
13913               evdwij=evdwij*eps2rt*eps3rt
13914               evdw=evdw+(evdwij+e_augm)*sss
13915               if (lprn) then
13916               sigm=dabs(aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
13917               epsi=bb_aq(itypi,itypj)**2/aa_aq(itypi,itypj)
13918               write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
13919                 restyp(itypi,1),i,restyp(itypj,1),j,&
13920                 epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),&
13921                 chi1,chi2,chip1,chip2,&
13922                 eps1,eps2rt**2,eps3rt**2,&
13923                 om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
13924                 evdwij+e_augm
13925               endif
13926 ! Calculate gradient components.
13927               e1=e1*eps1*eps2rt**2*eps3rt**2
13928               fac=-expon*(e1+evdwij)*rij_shift
13929               sigder=fac*sigder
13930               fac=rij*fac-2*expon*rrij*e_augm
13931 ! Calculate the radial part of the gradient
13932               gg(1)=xj*fac
13933               gg(2)=yj*fac
13934               gg(3)=zj*fac
13935 ! Calculate angular part of the gradient.
13936               call sc_grad_scale(sss)
13937             endif
13938           enddo      ! j
13939         enddo        ! iint
13940       enddo          ! i
13941       end subroutine egbv_short
13942 !-----------------------------------------------------------------------------
13943       subroutine eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
13944 !
13945 ! This subroutine calculates the average interaction energy and its gradient
13946 ! in the virtual-bond vectors between non-adjacent peptide groups, based on
13947 ! the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
13948 ! The potential depends both on the distance of peptide-group centers and on
13949 ! the orientation of the CA-CA virtual bonds.
13950 !
13951 !      implicit real*8 (a-h,o-z)
13952
13953       use comm_locel
13954 #ifdef MPI
13955       include 'mpif.h'
13956 #endif
13957 !      include 'DIMENSIONS'
13958 !      include 'COMMON.CONTROL'
13959 !      include 'COMMON.SETUP'
13960 !      include 'COMMON.IOUNITS'
13961 !      include 'COMMON.GEO'
13962 !      include 'COMMON.VAR'
13963 !      include 'COMMON.LOCAL'
13964 !      include 'COMMON.CHAIN'
13965 !      include 'COMMON.DERIV'
13966 !      include 'COMMON.INTERACT'
13967 !      include 'COMMON.CONTACTS'
13968 !      include 'COMMON.TORSION'
13969 !      include 'COMMON.VECTORS'
13970 !      include 'COMMON.FFIELD'
13971 !      include 'COMMON.TIME1'
13972       real(kind=8),dimension(3) :: ggg,gggp,gggm,erij,dcosb,dcosg
13973       real(kind=8),dimension(3,3) ::erder,uryg,urzg,vryg,vrzg
13974       real(kind=8),dimension(2,2) :: acipa !el,a_temp
13975 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
13976       real(kind=8),dimension(4) :: muij
13977 !el      integer :: num_conti,j1,j2
13978 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
13979 !el                   dz_normi,xmedi,ymedi,zmedi
13980 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
13981 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
13982 !el          num_conti,j1,j2
13983 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
13984 #ifdef MOMENT
13985       real(kind=8) :: scal_el=1.0d0
13986 #else
13987       real(kind=8) :: scal_el=0.5d0
13988 #endif
13989 ! 12/13/98
13990 ! 13-go grudnia roku pamietnego...
13991       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
13992                                              0.0d0,1.0d0,0.0d0,&
13993                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
13994 !el local variables
13995       integer :: i,j,k
13996       real(kind=8) :: fac
13997       real(kind=8) :: dxj,dyj,dzj
13998       real(kind=8) :: ees,evdw1,eel_loc,eello_turn3,eello_turn4
13999
14000 !      allocate(num_cont_hb(nres)) !(maxres)
14001 !d      write(iout,*) 'In EELEC'
14002 !d      do i=1,nloctyp
14003 !d        write(iout,*) 'Type',i
14004 !d        write(iout,*) 'B1',B1(:,i)
14005 !d        write(iout,*) 'B2',B2(:,i)
14006 !d        write(iout,*) 'CC',CC(:,:,i)
14007 !d        write(iout,*) 'DD',DD(:,:,i)
14008 !d        write(iout,*) 'EE',EE(:,:,i)
14009 !d      enddo
14010 !d      call check_vecgrad
14011 !d      stop
14012       if (icheckgrad.eq.1) then
14013         do i=1,nres-1
14014           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
14015           do k=1,3
14016             dc_norm(k,i)=dc(k,i)*fac
14017           enddo
14018 !          write (iout,*) 'i',i,' fac',fac
14019         enddo
14020       endif
14021       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14022           .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or. &
14023           wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
14024 !        call vec_and_deriv
14025 #ifdef TIMING
14026         time01=MPI_Wtime()
14027 #endif
14028 !        print *, "before set matrices"
14029         call set_matrices
14030 !        print *,"after set martices"
14031 #ifdef TIMING
14032         time_mat=time_mat+MPI_Wtime()-time01
14033 #endif
14034       endif
14035 !d      do i=1,nres-1
14036 !d        write (iout,*) 'i=',i
14037 !d        do k=1,3
14038 !d        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
14039 !d        enddo
14040 !d        do k=1,3
14041 !d          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
14042 !d     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
14043 !d        enddo
14044 !d      enddo
14045       t_eelecij=0.0d0
14046       ees=0.0D0
14047       evdw1=0.0D0
14048       eel_loc=0.0d0
14049       eello_turn3=0.0d0
14050       eello_turn4=0.0d0
14051 !el      ind=0
14052       do i=1,nres
14053         num_cont_hb(i)=0
14054       enddo
14055 !d      print '(a)','Enter EELEC'
14056 !d      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
14057 !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
14058 !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
14059       do i=1,nres
14060         gel_loc_loc(i)=0.0d0
14061         gcorr_loc(i)=0.0d0
14062       enddo
14063 !
14064 !
14065 ! 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
14066 !
14067 ! Loop over i,i+2 and i,i+3 pairs of the peptide groups
14068 !
14069       do i=iturn3_start,iturn3_end
14070         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1 &
14071         .or. itype(i+2,1).eq.ntyp1 .or. itype(i+3,1).eq.ntyp1) cycle
14072         dxi=dc(1,i)
14073         dyi=dc(2,i)
14074         dzi=dc(3,i)
14075         dx_normi=dc_norm(1,i)
14076         dy_normi=dc_norm(2,i)
14077         dz_normi=dc_norm(3,i)
14078         xmedi=c(1,i)+0.5d0*dxi
14079         ymedi=c(2,i)+0.5d0*dyi
14080         zmedi=c(3,i)+0.5d0*dzi
14081           xmedi=dmod(xmedi,boxxsize)
14082           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14083           ymedi=dmod(ymedi,boxysize)
14084           if (ymedi.lt.0) ymedi=ymedi+boxysize
14085           zmedi=dmod(zmedi,boxzsize)
14086           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14087         num_conti=0
14088         call eelecij_scale(i,i+2,ees,evdw1,eel_loc)
14089         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
14090         num_cont_hb(i)=num_conti
14091       enddo
14092       do i=iturn4_start,iturn4_end
14093         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1 &
14094           .or. itype(i+3,1).eq.ntyp1 &
14095           .or. itype(i+4,1).eq.ntyp1) cycle
14096         dxi=dc(1,i)
14097         dyi=dc(2,i)
14098         dzi=dc(3,i)
14099         dx_normi=dc_norm(1,i)
14100         dy_normi=dc_norm(2,i)
14101         dz_normi=dc_norm(3,i)
14102         xmedi=c(1,i)+0.5d0*dxi
14103         ymedi=c(2,i)+0.5d0*dyi
14104         zmedi=c(3,i)+0.5d0*dzi
14105           xmedi=dmod(xmedi,boxxsize)
14106           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14107           ymedi=dmod(ymedi,boxysize)
14108           if (ymedi.lt.0) ymedi=ymedi+boxysize
14109           zmedi=dmod(zmedi,boxzsize)
14110           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14111         num_conti=num_cont_hb(i)
14112         call eelecij_scale(i,i+3,ees,evdw1,eel_loc)
14113         if (wturn4.gt.0.0d0 .and. itype(i+2,1).ne.ntyp1) &
14114           call eturn4(i,eello_turn4)
14115         num_cont_hb(i)=num_conti
14116       enddo   ! i
14117 !
14118 ! Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
14119 !
14120       do i=iatel_s,iatel_e
14121         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
14122         dxi=dc(1,i)
14123         dyi=dc(2,i)
14124         dzi=dc(3,i)
14125         dx_normi=dc_norm(1,i)
14126         dy_normi=dc_norm(2,i)
14127         dz_normi=dc_norm(3,i)
14128         xmedi=c(1,i)+0.5d0*dxi
14129         ymedi=c(2,i)+0.5d0*dyi
14130         zmedi=c(3,i)+0.5d0*dzi
14131           xmedi=dmod(xmedi,boxxsize)
14132           if (xmedi.lt.0) xmedi=xmedi+boxxsize
14133           ymedi=dmod(ymedi,boxysize)
14134           if (ymedi.lt.0) ymedi=ymedi+boxysize
14135           zmedi=dmod(zmedi,boxzsize)
14136           if (zmedi.lt.0) zmedi=zmedi+boxzsize
14137 !        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
14138         num_conti=num_cont_hb(i)
14139         do j=ielstart(i),ielend(i)
14140           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
14141           call eelecij_scale(i,j,ees,evdw1,eel_loc)
14142         enddo ! j
14143         num_cont_hb(i)=num_conti
14144       enddo   ! i
14145 !      write (iout,*) "Number of loop steps in EELEC:",ind
14146 !d      do i=1,nres
14147 !d        write (iout,'(i3,3f10.5,5x,3f10.5)')
14148 !d     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
14149 !d      enddo
14150 ! 12/7/99 Adam eello_turn3 will be considered as a separate energy term
14151 !cc      eel_loc=eel_loc+eello_turn3
14152 !d      print *,"Processor",fg_rank," t_eelecij",t_eelecij
14153       return
14154       end subroutine eelec_scale
14155 !-----------------------------------------------------------------------------
14156       subroutine eelecij_scale(i,j,ees,evdw1,eel_loc)
14157 !      implicit real*8 (a-h,o-z)
14158
14159       use comm_locel
14160 !      include 'DIMENSIONS'
14161 #ifdef MPI
14162       include "mpif.h"
14163 #endif
14164 !      include 'COMMON.CONTROL'
14165 !      include 'COMMON.IOUNITS'
14166 !      include 'COMMON.GEO'
14167 !      include 'COMMON.VAR'
14168 !      include 'COMMON.LOCAL'
14169 !      include 'COMMON.CHAIN'
14170 !      include 'COMMON.DERIV'
14171 !      include 'COMMON.INTERACT'
14172 !      include 'COMMON.CONTACTS'
14173 !      include 'COMMON.TORSION'
14174 !      include 'COMMON.VECTORS'
14175 !      include 'COMMON.FFIELD'
14176 !      include 'COMMON.TIME1'
14177       real(kind=8),dimension(3) ::  ggg,gggp,gggm,erij,dcosb,dcosg,xtemp
14178       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
14179       real(kind=8),dimension(2,2) :: acipa !el,a_temp
14180 !el      real(kind=8),dimension(3,4) :: agg,aggi,aggi1,aggj,aggj1
14181       real(kind=8),dimension(4) :: muij
14182       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14183                     dist_temp, dist_init,sss_grad
14184       integer xshift,yshift,zshift
14185
14186 !el      integer :: num_conti,j1,j2
14187 !el      real(kind=8) :: a22,a23,a32,a33,dxi,dyi,dzi,dx_normi,dy_normi,&
14188 !el                   dz_normi,xmedi,ymedi,zmedi
14189 !el      common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,&
14190 !el          dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14191 !el          num_conti,j1,j2
14192 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14193 #ifdef MOMENT
14194       real(kind=8) :: scal_el=1.0d0
14195 #else
14196       real(kind=8) :: scal_el=0.5d0
14197 #endif
14198 ! 12/13/98
14199 ! 13-go grudnia roku pamietnego...
14200       real(kind=8),dimension(3,3) :: unmat=reshape((/1.0d0,0.0d0,0.0d0,&
14201                                              0.0d0,1.0d0,0.0d0,&
14202                                              0.0d0,0.0d0,1.0d0/),shape(unmat))
14203 !el local variables
14204       integer :: i,j,k,l,iteli,itelj,kkk,kkll,m,isubchap
14205       real(kind=8) :: aaa,bbb,ael6i,ael3i,dxj,dyj,dzj
14206       real(kind=8) :: xj,yj,zj,rij,rrmij,rmij,sss,r3ij,r6ij,fac
14207       real(kind=8) :: cosa,cosb,cosg,ev1,ev2,fac3,fac4,evdwij
14208       real(kind=8) :: el1,el2,eesij,ees0ij,r0ij,fcont,fprimcont
14209       real(kind=8) :: ees0tmp,ees0pij1,ees0mij1,ees0pijp,ees0mijp
14210       real(kind=8) :: ees,evdw1,eel_loc,eel_loc_ij,dx_normj,dy_normj,&
14211                   dz_normj,facvdw,facel,fac1,facr,ecosa,ecosb,ecosg,&
14212                   ury,urz,vry,vrz,a22der,a23der,a32der,a33der,cosa4,&
14213                   wij,cosbg1,cosbg2,ees0pij,ees0mij,fac3p,ecosa1,ecosb1,&
14214                   ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,ecosgp,&
14215                   ecosam,ecosbm,ecosgm,ghalf,time00
14216 !      integer :: maxconts
14217 !      maxconts = nres/4
14218 !      allocate(gacontp_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14219 !      allocate(gacontp_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14220 !      allocate(gacontp_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14221 !      allocate(gacontm_hb1(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14222 !      allocate(gacontm_hb2(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14223 !      allocate(gacontm_hb3(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14224 !      allocate(gacont_hbr(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14225 !      allocate(grij_hb_cont(3,maxconts,nres)) !(3,maxconts,maxres)  ! (maxconts=maxres/4)
14226 !      allocate(facont_hb(maxconts,nres)) !(maxconts,maxres)
14227 !      allocate(ees0p(maxconts,nres)) !(maxconts,maxres)
14228 !      allocate(ees0m(maxconts,nres)) !(maxconts,maxres)
14229 !      allocate(d_cont(maxconts,nres)) !(maxconts,maxres)
14230 !      allocate(jcont_hb(maxconts,nres)) !(maxconts,maxres)
14231
14232 !      allocate(a_chuj(2,2,maxconts,nres))      !(2,2,maxconts,maxres)
14233 !      allocate(a_chuj_der(2,2,3,5,maxconts,nres))      !(2,2,3,5,maxconts,maxres)
14234
14235 #ifdef MPI
14236           time00=MPI_Wtime()
14237 #endif
14238 !d      write (iout,*) "eelecij",i,j
14239 !el          ind=ind+1
14240           iteli=itel(i)
14241           itelj=itel(j)
14242           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
14243           aaa=app(iteli,itelj)
14244           bbb=bpp(iteli,itelj)
14245           ael6i=ael6(iteli,itelj)
14246           ael3i=ael3(iteli,itelj)
14247           dxj=dc(1,j)
14248           dyj=dc(2,j)
14249           dzj=dc(3,j)
14250           dx_normj=dc_norm(1,j)
14251           dy_normj=dc_norm(2,j)
14252           dz_normj=dc_norm(3,j)
14253 !          xj=c(1,j)+0.5D0*dxj-xmedi
14254 !          yj=c(2,j)+0.5D0*dyj-ymedi
14255 !          zj=c(3,j)+0.5D0*dzj-zmedi
14256           xj=c(1,j)+0.5D0*dxj
14257           yj=c(2,j)+0.5D0*dyj
14258           zj=c(3,j)+0.5D0*dzj
14259           xj=mod(xj,boxxsize)
14260           if (xj.lt.0) xj=xj+boxxsize
14261           yj=mod(yj,boxysize)
14262           if (yj.lt.0) yj=yj+boxysize
14263           zj=mod(zj,boxzsize)
14264           if (zj.lt.0) zj=zj+boxzsize
14265       isubchap=0
14266       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14267       xj_safe=xj
14268       yj_safe=yj
14269       zj_safe=zj
14270       do xshift=-1,1
14271       do yshift=-1,1
14272       do zshift=-1,1
14273           xj=xj_safe+xshift*boxxsize
14274           yj=yj_safe+yshift*boxysize
14275           zj=zj_safe+zshift*boxzsize
14276           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
14277           if(dist_temp.lt.dist_init) then
14278             dist_init=dist_temp
14279             xj_temp=xj
14280             yj_temp=yj
14281             zj_temp=zj
14282             isubchap=1
14283           endif
14284        enddo
14285        enddo
14286        enddo
14287        if (isubchap.eq.1) then
14288 !C          print *,i,j
14289           xj=xj_temp-xmedi
14290           yj=yj_temp-ymedi
14291           zj=zj_temp-zmedi
14292        else
14293           xj=xj_safe-xmedi
14294           yj=yj_safe-ymedi
14295           zj=zj_safe-zmedi
14296        endif
14297
14298           rij=xj*xj+yj*yj+zj*zj
14299           rrmij=1.0D0/rij
14300           rij=dsqrt(rij)
14301           rmij=1.0D0/rij
14302 ! For extracting the short-range part of Evdwpp
14303           sss=sscale(rij/rpp(iteli,itelj))
14304             sss_ele_cut=sscale_ele(rij)
14305             sss_ele_grad=sscagrad_ele(rij)
14306             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
14307 !             sss_ele_cut=1.0d0
14308 !             sss_ele_grad=0.0d0
14309             if (sss_ele_cut.le.0.0) go to 128
14310
14311           r3ij=rrmij*rmij
14312           r6ij=r3ij*r3ij
14313           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
14314           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
14315           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
14316           fac=cosa-3.0D0*cosb*cosg
14317           ev1=aaa*r6ij*r6ij
14318 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
14319           if (j.eq.i+2) ev1=scal_el*ev1
14320           ev2=bbb*r6ij
14321           fac3=ael6i*r6ij
14322           fac4=ael3i*r3ij
14323           evdwij=ev1+ev2
14324           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
14325           el2=fac4*fac
14326           eesij=el1+el2
14327 ! 12/26/95 - for the evaluation of multi-body H-bonding interactions
14328           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
14329           ees=ees+eesij*sss_ele_cut
14330           evdw1=evdw1+evdwij*(1.0d0-sss)*sss_ele_cut
14331 !d          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
14332 !d     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
14333 !d     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
14334 !d     &      xmedi,ymedi,zmedi,xj,yj,zj
14335
14336           if (energy_dec) then
14337               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
14338               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
14339           endif
14340
14341 !
14342 ! Calculate contributions to the Cartesian gradient.
14343 !
14344 #ifdef SPLITELE
14345           facvdw=-6*rrmij*(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14346           facel=-3*rrmij*(el1+eesij)*sss_ele_cut
14347           fac1=fac
14348           erij(1)=xj*rmij
14349           erij(2)=yj*rmij
14350           erij(3)=zj*rmij
14351 !
14352 ! Radial derivatives. First process both termini of the fragment (i,j)
14353 !
14354           ggg(1)=facel*xj+sss_ele_grad*rmij*eesij*xj
14355           ggg(2)=facel*yj+sss_ele_grad*rmij*eesij*yj
14356           ggg(3)=facel*zj+sss_ele_grad*rmij*eesij*zj
14357 !          do k=1,3
14358 !            ghalf=0.5D0*ggg(k)
14359 !            gelc(k,i)=gelc(k,i)+ghalf
14360 !            gelc(k,j)=gelc(k,j)+ghalf
14361 !          enddo
14362 ! 9/28/08 AL Gradient compotents will be summed only at the end
14363           do k=1,3
14364             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14365             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14366           enddo
14367 !
14368 ! Loop over residues i+1 thru j-1.
14369 !
14370 !grad          do k=i+1,j-1
14371 !grad            do l=1,3
14372 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14373 !grad            enddo
14374 !grad          enddo
14375           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*(1.0d0-sss)  &
14376           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
14377           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*(1.0d0-sss)  &
14378           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
14379           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*(1.0d0-sss)  &
14380           -evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
14381 !          do k=1,3
14382 !            ghalf=0.5D0*ggg(k)
14383 !            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
14384 !            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
14385 !          enddo
14386 ! 9/28/08 AL Gradient compotents will be summed only at the end
14387           do k=1,3
14388             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14389             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14390           enddo
14391 !
14392 ! Loop over residues i+1 thru j-1.
14393 !
14394 !grad          do k=i+1,j-1
14395 !grad            do l=1,3
14396 !grad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
14397 !grad            enddo
14398 !grad          enddo
14399 #else
14400           facvdw=(ev1+evdwij)*(1.0d0-sss)*sss_ele_cut
14401           facel=(el1+eesij)*sss_ele_cut
14402           fac1=fac
14403           fac=-3*rrmij*(facvdw+facvdw+facel)
14404           erij(1)=xj*rmij
14405           erij(2)=yj*rmij
14406           erij(3)=zj*rmij
14407 !
14408 ! Radial derivatives. First process both termini of the fragment (i,j)
14409 !
14410           ggg(1)=fac*xj
14411           ggg(2)=fac*yj
14412           ggg(3)=fac*zj
14413 !          do k=1,3
14414 !            ghalf=0.5D0*ggg(k)
14415 !            gelc(k,i)=gelc(k,i)+ghalf
14416 !            gelc(k,j)=gelc(k,j)+ghalf
14417 !          enddo
14418 ! 9/28/08 AL Gradient compotents will be summed only at the end
14419           do k=1,3
14420             gelc_long(k,j)=gelc(k,j)+ggg(k)
14421             gelc_long(k,i)=gelc(k,i)-ggg(k)
14422           enddo
14423 !
14424 ! Loop over residues i+1 thru j-1.
14425 !
14426 !grad          do k=i+1,j-1
14427 !grad            do l=1,3
14428 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14429 !grad            enddo
14430 !grad          enddo
14431 ! 9/28/08 AL Gradient compotents will be summed only at the end
14432           ggg(1)=facvdw*xj
14433           ggg(2)=facvdw*yj
14434           ggg(3)=facvdw*zj
14435           do k=1,3
14436             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
14437             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
14438           enddo
14439 #endif
14440 !
14441 ! Angular part
14442 !
14443           ecosa=2.0D0*fac3*fac1+fac4
14444           fac4=-3.0D0*fac4
14445           fac3=-6.0D0*fac3
14446           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
14447           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
14448           do k=1,3
14449             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14450             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14451           enddo
14452 !d        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
14453 !d   &          (dcosg(k),k=1,3)
14454           do k=1,3
14455             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k) )*sss_ele_cut
14456           enddo
14457 !          do k=1,3
14458 !            ghalf=0.5D0*ggg(k)
14459 !            gelc(k,i)=gelc(k,i)+ghalf
14460 !     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
14461 !     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14462 !            gelc(k,j)=gelc(k,j)+ghalf
14463 !     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
14464 !     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14465 !          enddo
14466 !grad          do k=i+1,j-1
14467 !grad            do l=1,3
14468 !grad              gelc(l,k)=gelc(l,k)+ggg(l)
14469 !grad            enddo
14470 !grad          enddo
14471           do k=1,3
14472             gelc(k,i)=gelc(k,i) &
14473                      +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14474                      + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)&
14475                      *sss_ele_cut
14476             gelc(k,j)=gelc(k,j) &
14477                      +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14478                      + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14479                      *sss_ele_cut
14480             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
14481             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
14482           enddo
14483           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 &
14484               .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 &
14485               .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14486 !
14487 ! 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
14488 !   energy of a peptide unit is assumed in the form of a second-order
14489 !   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
14490 !   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
14491 !   are computed for EVERY pair of non-contiguous peptide groups.
14492 !
14493           if (j.lt.nres-1) then
14494             j1=j+1
14495             j2=j-1
14496           else
14497             j1=j-1
14498             j2=j-2
14499           endif
14500           kkk=0
14501           do k=1,2
14502             do l=1,2
14503               kkk=kkk+1
14504               muij(kkk)=mu(k,i)*mu(l,j)
14505             enddo
14506           enddo
14507 !d         write (iout,*) 'EELEC: i',i,' j',j
14508 !d          write (iout,*) 'j',j,' j1',j1,' j2',j2
14509 !d          write(iout,*) 'muij',muij
14510           ury=scalar(uy(1,i),erij)
14511           urz=scalar(uz(1,i),erij)
14512           vry=scalar(uy(1,j),erij)
14513           vrz=scalar(uz(1,j),erij)
14514           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
14515           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
14516           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
14517           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
14518           fac=dsqrt(-ael6i)*r3ij
14519           a22=a22*fac
14520           a23=a23*fac
14521           a32=a32*fac
14522           a33=a33*fac
14523 !d          write (iout,'(4i5,4f10.5)')
14524 !d     &     i,itortyp(itype(i,1)),j,itortyp(itype(j,1)),a22,a23,a32,a33
14525 !d          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
14526 !d          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
14527 !d     &      uy(:,j),uz(:,j)
14528 !d          write (iout,'(4f10.5)')
14529 !d     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
14530 !d     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
14531 !d          write (iout,'(4f10.5)') ury,urz,vry,vrz
14532 !d           write (iout,'(9f10.5/)')
14533 !d     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
14534 ! Derivatives of the elements of A in virtual-bond vectors
14535           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
14536           do k=1,3
14537             uryg(k,1)=scalar(erder(1,k),uy(1,i))
14538             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
14539             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
14540             urzg(k,1)=scalar(erder(1,k),uz(1,i))
14541             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
14542             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
14543             vryg(k,1)=scalar(erder(1,k),uy(1,j))
14544             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
14545             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
14546             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
14547             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
14548             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
14549           enddo
14550 ! Compute radial contributions to the gradient
14551           facr=-3.0d0*rrmij
14552           a22der=a22*facr
14553           a23der=a23*facr
14554           a32der=a32*facr
14555           a33der=a33*facr
14556           agg(1,1)=a22der*xj
14557           agg(2,1)=a22der*yj
14558           agg(3,1)=a22der*zj
14559           agg(1,2)=a23der*xj
14560           agg(2,2)=a23der*yj
14561           agg(3,2)=a23der*zj
14562           agg(1,3)=a32der*xj
14563           agg(2,3)=a32der*yj
14564           agg(3,3)=a32der*zj
14565           agg(1,4)=a33der*xj
14566           agg(2,4)=a33der*yj
14567           agg(3,4)=a33der*zj
14568 ! Add the contributions coming from er
14569           fac3=-3.0d0*fac
14570           do k=1,3
14571             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
14572             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
14573             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
14574             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
14575           enddo
14576           do k=1,3
14577 ! Derivatives in DC(i)
14578 !grad            ghalf1=0.5d0*agg(k,1)
14579 !grad            ghalf2=0.5d0*agg(k,2)
14580 !grad            ghalf3=0.5d0*agg(k,3)
14581 !grad            ghalf4=0.5d0*agg(k,4)
14582             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j)) &
14583             -3.0d0*uryg(k,2)*vry)!+ghalf1
14584             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j)) &
14585             -3.0d0*uryg(k,2)*vrz)!+ghalf2
14586             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j)) &
14587             -3.0d0*urzg(k,2)*vry)!+ghalf3
14588             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j)) &
14589             -3.0d0*urzg(k,2)*vrz)!+ghalf4
14590 ! Derivatives in DC(i+1)
14591             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j)) &
14592             -3.0d0*uryg(k,3)*vry)!+agg(k,1)
14593             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j)) &
14594             -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
14595             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j)) &
14596             -3.0d0*urzg(k,3)*vry)!+agg(k,3)
14597             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j)) &
14598             -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
14599 ! Derivatives in DC(j)
14600             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i)) &
14601             -3.0d0*vryg(k,2)*ury)!+ghalf1
14602             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i)) &
14603             -3.0d0*vrzg(k,2)*ury)!+ghalf2
14604             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i)) &
14605             -3.0d0*vryg(k,2)*urz)!+ghalf3
14606             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i)) &
14607             -3.0d0*vrzg(k,2)*urz)!+ghalf4
14608 ! Derivatives in DC(j+1) or DC(nres-1)
14609             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i)) &
14610             -3.0d0*vryg(k,3)*ury)
14611             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i)) &
14612             -3.0d0*vrzg(k,3)*ury)
14613             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i)) &
14614             -3.0d0*vryg(k,3)*urz)
14615             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i)) &
14616             -3.0d0*vrzg(k,3)*urz)
14617 !grad            if (j.eq.nres-1 .and. i.lt.j-2) then
14618 !grad              do l=1,4
14619 !grad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
14620 !grad              enddo
14621 !grad            endif
14622           enddo
14623           acipa(1,1)=a22
14624           acipa(1,2)=a23
14625           acipa(2,1)=a32
14626           acipa(2,2)=a33
14627           a22=-a22
14628           a23=-a23
14629           do l=1,2
14630             do k=1,3
14631               agg(k,l)=-agg(k,l)
14632               aggi(k,l)=-aggi(k,l)
14633               aggi1(k,l)=-aggi1(k,l)
14634               aggj(k,l)=-aggj(k,l)
14635               aggj1(k,l)=-aggj1(k,l)
14636             enddo
14637           enddo
14638           if (j.lt.nres-1) then
14639             a22=-a22
14640             a32=-a32
14641             do l=1,3,2
14642               do k=1,3
14643                 agg(k,l)=-agg(k,l)
14644                 aggi(k,l)=-aggi(k,l)
14645                 aggi1(k,l)=-aggi1(k,l)
14646                 aggj(k,l)=-aggj(k,l)
14647                 aggj1(k,l)=-aggj1(k,l)
14648               enddo
14649             enddo
14650           else
14651             a22=-a22
14652             a23=-a23
14653             a32=-a32
14654             a33=-a33
14655             do l=1,4
14656               do k=1,3
14657                 agg(k,l)=-agg(k,l)
14658                 aggi(k,l)=-aggi(k,l)
14659                 aggi1(k,l)=-aggi1(k,l)
14660                 aggj(k,l)=-aggj(k,l)
14661                 aggj1(k,l)=-aggj1(k,l)
14662               enddo
14663             enddo
14664           endif
14665           ENDIF ! WCORR
14666           IF (wel_loc.gt.0.0d0) THEN
14667 ! Contribution to the local-electrostatic energy coming from the i-j pair
14668           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3) &
14669            +a33*muij(4)
14670 !          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
14671 !           print *,"EELLOC",i,gel_loc_loc(i-1)
14672           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
14673                   'eelloc',i,j,eel_loc_ij
14674 !              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3) !d
14675
14676           eel_loc=eel_loc+eel_loc_ij*sss_ele_cut
14677 ! Partial derivatives in virtual-bond dihedral angles gamma
14678           if (i.gt.1) &
14679           gel_loc_loc(i-1)=gel_loc_loc(i-1)+ &
14680                   (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j) &
14681                  +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)) &
14682                  *sss_ele_cut
14683           gel_loc_loc(j-1)=gel_loc_loc(j-1)+ &
14684                   (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j) &
14685                  +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)) &
14686                  *sss_ele_cut
14687            xtemp(1)=xj
14688            xtemp(2)=yj
14689            xtemp(3)=zj
14690
14691 ! Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
14692           do l=1,3
14693             ggg(l)=(agg(l,1)*muij(1)+ &
14694                 agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))&
14695             *sss_ele_cut &
14696              +eel_loc_ij*sss_ele_grad*rmij*xtemp(l)
14697
14698             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
14699             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
14700 !grad            ghalf=0.5d0*ggg(l)
14701 !grad            gel_loc(l,i)=gel_loc(l,i)+ghalf
14702 !grad            gel_loc(l,j)=gel_loc(l,j)+ghalf
14703           enddo
14704 !grad          do k=i+1,j2
14705 !grad            do l=1,3
14706 !grad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
14707 !grad            enddo
14708 !grad          enddo
14709 ! Remaining derivatives of eello
14710           do l=1,3
14711             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+ &
14712                 aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))&
14713             *sss_ele_cut
14714
14715             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+ &
14716                 aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))&
14717             *sss_ele_cut
14718
14719             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+ &
14720                 aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))&
14721             *sss_ele_cut
14722
14723             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+ &
14724                 aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))&
14725             *sss_ele_cut
14726
14727           enddo
14728           ENDIF
14729 ! Change 12/26/95 to calculate four-body contributions to H-bonding energy
14730 !          if (j.gt.i+1 .and. num_conti.le.maxconts) then
14731           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0 &
14732              .and. num_conti.le.maxconts) then
14733 !            write (iout,*) i,j," entered corr"
14734 !
14735 ! Calculate the contact function. The ith column of the array JCONT will
14736 ! contain the numbers of atoms that make contacts with the atom I (of numbers
14737 ! greater than I). The arrays FACONT and GACONT will contain the values of
14738 ! the contact function and its derivative.
14739 !           r0ij=1.02D0*rpp(iteli,itelj)
14740 !           r0ij=1.11D0*rpp(iteli,itelj)
14741             r0ij=2.20D0*rpp(iteli,itelj)
14742 !           r0ij=1.55D0*rpp(iteli,itelj)
14743             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
14744 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14745             if (fcont.gt.0.0D0) then
14746               num_conti=num_conti+1
14747               if (num_conti.gt.maxconts) then
14748 !elwrite(iout,*) "num_conti",num_conti, "maxconts",maxconts
14749                 write (iout,*) 'WARNING - max. # of contacts exceeded;',&
14750                                ' will skip next contacts for this conf.',num_conti
14751               else
14752                 jcont_hb(num_conti,i)=j
14753 !d                write (iout,*) "i",i," j",j," num_conti",num_conti,
14754 !d     &           " jcont_hb",jcont_hb(num_conti,i)
14755                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. &
14756                 wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
14757 ! 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
14758 !  terms.
14759                 d_cont(num_conti,i)=rij
14760 !d                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
14761 !     --- Electrostatic-interaction matrix ---
14762                 a_chuj(1,1,num_conti,i)=a22
14763                 a_chuj(1,2,num_conti,i)=a23
14764                 a_chuj(2,1,num_conti,i)=a32
14765                 a_chuj(2,2,num_conti,i)=a33
14766 !     --- Gradient of rij
14767                 do kkk=1,3
14768                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
14769                 enddo
14770                 kkll=0
14771                 do k=1,2
14772                   do l=1,2
14773                     kkll=kkll+1
14774                     do m=1,3
14775                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
14776                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
14777                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
14778                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
14779                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
14780                     enddo
14781                   enddo
14782                 enddo
14783                 ENDIF
14784                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
14785 ! Calculate contact energies
14786                 cosa4=4.0D0*cosa
14787                 wij=cosa-3.0D0*cosb*cosg
14788                 cosbg1=cosb+cosg
14789                 cosbg2=cosb-cosg
14790 !               fac3=dsqrt(-ael6i)/r0ij**3
14791                 fac3=dsqrt(-ael6i)*r3ij
14792 !                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
14793                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
14794                 if (ees0tmp.gt.0) then
14795                   ees0pij=dsqrt(ees0tmp)
14796                 else
14797                   ees0pij=0
14798                 endif
14799 !                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
14800                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
14801                 if (ees0tmp.gt.0) then
14802                   ees0mij=dsqrt(ees0tmp)
14803                 else
14804                   ees0mij=0
14805                 endif
14806 !               ees0mij=0.0D0
14807                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij) &
14808                      *sss_ele_cut
14809
14810                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij) &
14811                      *sss_ele_cut
14812
14813 ! Diagnostics. Comment out or remove after debugging!
14814 !               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
14815 !               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
14816 !               ees0m(num_conti,i)=0.0D0
14817 ! End diagnostics.
14818 !               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
14819 !    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
14820 ! Angular derivatives of the contact function
14821                 ees0pij1=fac3/ees0pij
14822                 ees0mij1=fac3/ees0mij
14823                 fac3p=-3.0D0*fac3*rrmij
14824                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
14825                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
14826 !               ees0mij1=0.0D0
14827                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
14828                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
14829                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
14830                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
14831                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
14832                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
14833                 ecosap=ecosa1+ecosa2
14834                 ecosbp=ecosb1+ecosb2
14835                 ecosgp=ecosg1+ecosg2
14836                 ecosam=ecosa1-ecosa2
14837                 ecosbm=ecosb1-ecosb2
14838                 ecosgm=ecosg1-ecosg2
14839 ! Diagnostics
14840 !               ecosap=ecosa1
14841 !               ecosbp=ecosb1
14842 !               ecosgp=ecosg1
14843 !               ecosam=0.0D0
14844 !               ecosbm=0.0D0
14845 !               ecosgm=0.0D0
14846 ! End diagnostics
14847                 facont_hb(num_conti,i)=fcont
14848                 fprimcont=fprimcont/rij
14849 !d              facont_hb(num_conti,i)=1.0D0
14850 ! Following line is for diagnostics.
14851 !d              fprimcont=0.0D0
14852                 do k=1,3
14853                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
14854                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
14855                 enddo
14856                 do k=1,3
14857                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
14858                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
14859                 enddo
14860 !                gggp(1)=gggp(1)+ees0pijp*xj
14861 !                gggp(2)=gggp(2)+ees0pijp*yj
14862 !                gggp(3)=gggp(3)+ees0pijp*zj
14863 !                gggm(1)=gggm(1)+ees0mijp*xj
14864 !                gggm(2)=gggm(2)+ees0mijp*yj
14865 !                gggm(3)=gggm(3)+ees0mijp*zj
14866                 gggp(1)=gggp(1)+ees0pijp*xj &
14867                   +ees0p(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14868                 gggp(2)=gggp(2)+ees0pijp*yj &
14869                +ees0p(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14870                 gggp(3)=gggp(3)+ees0pijp*zj &
14871                +ees0p(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14872
14873                 gggm(1)=gggm(1)+ees0mijp*xj &
14874                +ees0m(num_conti,i)/sss_ele_cut*rmij*xj*sss_ele_grad
14875
14876                 gggm(2)=gggm(2)+ees0mijp*yj &
14877                +ees0m(num_conti,i)/sss_ele_cut*rmij*yj*sss_ele_grad
14878
14879                 gggm(3)=gggm(3)+ees0mijp*zj &
14880                +ees0m(num_conti,i)/sss_ele_cut*rmij*zj*sss_ele_grad
14881
14882 ! Derivatives due to the contact function
14883                 gacont_hbr(1,num_conti,i)=fprimcont*xj
14884                 gacont_hbr(2,num_conti,i)=fprimcont*yj
14885                 gacont_hbr(3,num_conti,i)=fprimcont*zj
14886                 do k=1,3
14887 !
14888 ! 10/24/08 cgrad and ! comments indicate the parts of the code removed
14889 !          following the change of gradient-summation algorithm.
14890 !
14891 !grad                  ghalfp=0.5D0*gggp(k)
14892 !grad                  ghalfm=0.5D0*gggm(k)
14893 !                  gacontp_hb1(k,num_conti,i)= & !ghalfp
14894 !                    +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14895 !                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14896 !                  gacontp_hb2(k,num_conti,i)= & !ghalfp
14897 !                    +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14898 !                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14899 !                  gacontp_hb3(k,num_conti,i)=gggp(k)
14900 !                  gacontm_hb1(k,num_conti,i)=  &!ghalfm
14901 !                    +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14902 !                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
14903 !                  gacontm_hb2(k,num_conti,i)= & !ghalfm
14904 !                    +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14905 !                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
14906 !                  gacontm_hb3(k,num_conti,i)=gggm(k)
14907                   gacontp_hb1(k,num_conti,i)= & !ghalfp+
14908                     (ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14909                    + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14910                      *sss_ele_cut
14911
14912                   gacontp_hb2(k,num_conti,i)= & !ghalfp+
14913                     (ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14914                    + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)&
14915                      *sss_ele_cut
14916
14917                   gacontp_hb3(k,num_conti,i)=gggp(k) &
14918                      *sss_ele_cut
14919
14920                   gacontm_hb1(k,num_conti,i)= & !ghalfm+
14921                     (ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i)) &
14922                    + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1) &
14923                      *sss_ele_cut
14924
14925                   gacontm_hb2(k,num_conti,i)= & !ghalfm+
14926                     (ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j)) &
14927                    + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1) &
14928                      *sss_ele_cut
14929
14930                   gacontm_hb3(k,num_conti,i)=gggm(k) &
14931                      *sss_ele_cut
14932
14933                 enddo
14934               ENDIF ! wcorr
14935               endif  ! num_conti.le.maxconts
14936             endif  ! fcont.gt.0
14937           endif    ! j.gt.i+1
14938           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
14939             do k=1,4
14940               do l=1,3
14941                 ghalf=0.5d0*agg(l,k)
14942                 aggi(l,k)=aggi(l,k)+ghalf
14943                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
14944                 aggj(l,k)=aggj(l,k)+ghalf
14945               enddo
14946             enddo
14947             if (j.eq.nres-1 .and. i.lt.j-2) then
14948               do k=1,4
14949                 do l=1,3
14950                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
14951                 enddo
14952               enddo
14953             endif
14954           endif
14955  128      continue
14956 !          t_eelecij=t_eelecij+MPI_Wtime()-time00
14957       return
14958       end subroutine eelecij_scale
14959 !-----------------------------------------------------------------------------
14960       subroutine evdwpp_short(evdw1)
14961 !
14962 ! Compute Evdwpp
14963 !
14964 !      implicit real*8 (a-h,o-z)
14965 !      include 'DIMENSIONS'
14966 !      include 'COMMON.CONTROL'
14967 !      include 'COMMON.IOUNITS'
14968 !      include 'COMMON.GEO'
14969 !      include 'COMMON.VAR'
14970 !      include 'COMMON.LOCAL'
14971 !      include 'COMMON.CHAIN'
14972 !      include 'COMMON.DERIV'
14973 !      include 'COMMON.INTERACT'
14974 !      include 'COMMON.CONTACTS'
14975 !      include 'COMMON.TORSION'
14976 !      include 'COMMON.VECTORS'
14977 !      include 'COMMON.FFIELD'
14978       real(kind=8),dimension(3) :: ggg
14979 ! 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
14980 #ifdef MOMENT
14981       real(kind=8) :: scal_el=1.0d0
14982 #else
14983       real(kind=8) :: scal_el=0.5d0
14984 #endif
14985 !el local variables
14986       integer :: i,j,k,iteli,itelj,num_conti,isubchap
14987       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
14988       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
14989                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
14990                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
14991       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
14992                     dist_temp, dist_init,sss_grad
14993       integer xshift,yshift,zshift
14994
14995
14996       evdw1=0.0D0
14997 !      write (iout,*) "iatel_s_vdw",iatel_s_vdw,
14998 !     & " iatel_e_vdw",iatel_e_vdw
14999       call flush(iout)
15000       do i=iatel_s_vdw,iatel_e_vdw
15001         if (itype(i,1).eq.ntyp1.or. itype(i+1,1).eq.ntyp1) cycle
15002         dxi=dc(1,i)
15003         dyi=dc(2,i)
15004         dzi=dc(3,i)
15005         dx_normi=dc_norm(1,i)
15006         dy_normi=dc_norm(2,i)
15007         dz_normi=dc_norm(3,i)
15008         xmedi=c(1,i)+0.5d0*dxi
15009         ymedi=c(2,i)+0.5d0*dyi
15010         zmedi=c(3,i)+0.5d0*dzi
15011           xmedi=dmod(xmedi,boxxsize)
15012           if (xmedi.lt.0) xmedi=xmedi+boxxsize
15013           ymedi=dmod(ymedi,boxysize)
15014           if (ymedi.lt.0) ymedi=ymedi+boxysize
15015           zmedi=dmod(zmedi,boxzsize)
15016           if (zmedi.lt.0) zmedi=zmedi+boxzsize
15017         num_conti=0
15018 !        write (iout,*) 'i',i,' ielstart',ielstart_vdw(i),
15019 !     &   ' ielend',ielend_vdw(i)
15020         call flush(iout)
15021         do j=ielstart_vdw(i),ielend_vdw(i)
15022           if (itype(j,1).eq.ntyp1 .or. itype(j+1,1).eq.ntyp1) cycle
15023 !el          ind=ind+1
15024           iteli=itel(i)
15025           itelj=itel(j)
15026           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
15027           aaa=app(iteli,itelj)
15028           bbb=bpp(iteli,itelj)
15029           dxj=dc(1,j)
15030           dyj=dc(2,j)
15031           dzj=dc(3,j)
15032           dx_normj=dc_norm(1,j)
15033           dy_normj=dc_norm(2,j)
15034           dz_normj=dc_norm(3,j)
15035 !          xj=c(1,j)+0.5D0*dxj-xmedi
15036 !          yj=c(2,j)+0.5D0*dyj-ymedi
15037 !          zj=c(3,j)+0.5D0*dzj-zmedi
15038           xj=c(1,j)+0.5D0*dxj
15039           yj=c(2,j)+0.5D0*dyj
15040           zj=c(3,j)+0.5D0*dzj
15041           xj=mod(xj,boxxsize)
15042           if (xj.lt.0) xj=xj+boxxsize
15043           yj=mod(yj,boxysize)
15044           if (yj.lt.0) yj=yj+boxysize
15045           zj=mod(zj,boxzsize)
15046           if (zj.lt.0) zj=zj+boxzsize
15047       isubchap=0
15048       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15049       xj_safe=xj
15050       yj_safe=yj
15051       zj_safe=zj
15052       do xshift=-1,1
15053       do yshift=-1,1
15054       do zshift=-1,1
15055           xj=xj_safe+xshift*boxxsize
15056           yj=yj_safe+yshift*boxysize
15057           zj=zj_safe+zshift*boxzsize
15058           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
15059           if(dist_temp.lt.dist_init) then
15060             dist_init=dist_temp
15061             xj_temp=xj
15062             yj_temp=yj
15063             zj_temp=zj
15064             isubchap=1
15065           endif
15066        enddo
15067        enddo
15068        enddo
15069        if (isubchap.eq.1) then
15070 !C          print *,i,j
15071           xj=xj_temp-xmedi
15072           yj=yj_temp-ymedi
15073           zj=zj_temp-zmedi
15074        else
15075           xj=xj_safe-xmedi
15076           yj=yj_safe-ymedi
15077           zj=zj_safe-zmedi
15078        endif
15079
15080           rij=xj*xj+yj*yj+zj*zj
15081           rrmij=1.0D0/rij
15082           rij=dsqrt(rij)
15083           sss=sscale(rij/rpp(iteli,itelj))
15084             sss_ele_cut=sscale_ele(rij)
15085             sss_ele_grad=sscagrad_ele(rij)
15086             sss_grad=sscale_grad((rij/rpp(iteli,itelj)))
15087             if (sss_ele_cut.le.0.0) cycle
15088           if (sss.gt.0.0d0) then
15089             rmij=1.0D0/rij
15090             r3ij=rrmij*rmij
15091             r6ij=r3ij*r3ij
15092             ev1=aaa*r6ij*r6ij
15093 ! 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
15094             if (j.eq.i+2) ev1=scal_el*ev1
15095             ev2=bbb*r6ij
15096             evdwij=ev1+ev2
15097             if (energy_dec) then
15098               write (iout,'(a6,2i5,0pf7.3,f7.3)') 'evdw1',i,j,evdwij,sss
15099             endif
15100             evdw1=evdw1+evdwij*sss*sss_ele_cut
15101 !
15102 ! Calculate contributions to the Cartesian gradient.
15103 !
15104             facvdw=-6*rrmij*(ev1+evdwij)*sss*sss_ele_cut
15105 !            ggg(1)=facvdw*xj
15106 !            ggg(2)=facvdw*yj
15107 !            ggg(3)=facvdw*zj
15108           ggg(1)=facvdw*xj+sss_ele_grad*rmij*evdwij*xj*sss  &
15109           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*xj
15110           ggg(2)=facvdw*yj+sss_ele_grad*rmij*evdwij*yj*sss  &
15111           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*yj
15112           ggg(3)=facvdw*zj+sss_ele_grad*rmij*evdwij*zj*sss  &
15113           +evdwij*sss_ele_cut/rij*sss_grad/rpp(iteli,itelj)*zj
15114
15115             do k=1,3
15116               gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
15117               gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
15118             enddo
15119           endif
15120         enddo ! j
15121       enddo   ! i
15122       return
15123       end subroutine evdwpp_short
15124 !-----------------------------------------------------------------------------
15125       subroutine escp_long(evdw2,evdw2_14)
15126 !
15127 ! This subroutine calculates the excluded-volume interaction energy between
15128 ! peptide-group centers and side chains and its gradient in virtual-bond and
15129 ! side-chain vectors.
15130 !
15131 !      implicit real*8 (a-h,o-z)
15132 !      include 'DIMENSIONS'
15133 !      include 'COMMON.GEO'
15134 !      include 'COMMON.VAR'
15135 !      include 'COMMON.LOCAL'
15136 !      include 'COMMON.CHAIN'
15137 !      include 'COMMON.DERIV'
15138 !      include 'COMMON.INTERACT'
15139 !      include 'COMMON.FFIELD'
15140 !      include 'COMMON.IOUNITS'
15141 !      include 'COMMON.CONTROL'
15142       real(kind=8),dimension(3) :: ggg
15143 !el local variables
15144       integer :: i,iint,j,k,iteli,itypj,subchap
15145       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15146       real(kind=8) :: evdw2,evdw2_14,evdwij
15147       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15148                     dist_temp, dist_init
15149
15150       evdw2=0.0D0
15151       evdw2_14=0.0d0
15152 !d    print '(a)','Enter ESCP'
15153 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15154       do i=iatscp_s,iatscp_e
15155         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15156         iteli=itel(i)
15157         xi=0.5D0*(c(1,i)+c(1,i+1))
15158         yi=0.5D0*(c(2,i)+c(2,i+1))
15159         zi=0.5D0*(c(3,i)+c(3,i+1))
15160           xi=mod(xi,boxxsize)
15161           if (xi.lt.0) xi=xi+boxxsize
15162           yi=mod(yi,boxysize)
15163           if (yi.lt.0) yi=yi+boxysize
15164           zi=mod(zi,boxzsize)
15165           if (zi.lt.0) zi=zi+boxzsize
15166
15167         do iint=1,nscp_gr(i)
15168
15169         do j=iscpstart(i,iint),iscpend(i,iint)
15170           itypj=itype(j,1)
15171           if (itypj.eq.ntyp1) cycle
15172 ! Uncomment following three lines for SC-p interactions
15173 !         xj=c(1,nres+j)-xi
15174 !         yj=c(2,nres+j)-yi
15175 !         zj=c(3,nres+j)-zi
15176 ! Uncomment following three lines for Ca-p interactions
15177           xj=c(1,j)
15178           yj=c(2,j)
15179           zj=c(3,j)
15180           xj=mod(xj,boxxsize)
15181           if (xj.lt.0) xj=xj+boxxsize
15182           yj=mod(yj,boxysize)
15183           if (yj.lt.0) yj=yj+boxysize
15184           zj=mod(zj,boxzsize)
15185           if (zj.lt.0) zj=zj+boxzsize
15186       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15187       xj_safe=xj
15188       yj_safe=yj
15189       zj_safe=zj
15190       subchap=0
15191       do xshift=-1,1
15192       do yshift=-1,1
15193       do zshift=-1,1
15194           xj=xj_safe+xshift*boxxsize
15195           yj=yj_safe+yshift*boxysize
15196           zj=zj_safe+zshift*boxzsize
15197           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15198           if(dist_temp.lt.dist_init) then
15199             dist_init=dist_temp
15200             xj_temp=xj
15201             yj_temp=yj
15202             zj_temp=zj
15203             subchap=1
15204           endif
15205        enddo
15206        enddo
15207        enddo
15208        if (subchap.eq.1) then
15209           xj=xj_temp-xi
15210           yj=yj_temp-yi
15211           zj=zj_temp-zi
15212        else
15213           xj=xj_safe-xi
15214           yj=yj_safe-yi
15215           zj=zj_safe-zi
15216        endif
15217           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15218
15219           rij=dsqrt(1.0d0/rrij)
15220             sss_ele_cut=sscale_ele(rij)
15221             sss_ele_grad=sscagrad_ele(rij)
15222 !            print *,sss_ele_cut,sss_ele_grad,&
15223 !            (rij),r_cut_ele,rlamb_ele
15224             if (sss_ele_cut.le.0.0) cycle
15225           sss=sscale((rij/rscp(itypj,iteli)))
15226           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15227           if (sss.lt.1.0d0) then
15228
15229             fac=rrij**expon2
15230             e1=fac*fac*aad(itypj,iteli)
15231             e2=fac*bad(itypj,iteli)
15232             if (iabs(j-i) .le. 2) then
15233               e1=scal14*e1
15234               e2=scal14*e2
15235               evdw2_14=evdw2_14+(e1+e2)*(1.0d0-sss)*sss_ele_cut
15236             endif
15237             evdwij=e1+e2
15238             evdw2=evdw2+evdwij*(1.0d0-sss)*sss_ele_cut
15239             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15240                 'evdw2',i,j,sss,evdwij
15241 !
15242 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15243 !
15244             fac=-(evdwij+e1)*rrij*(1.0d0-sss)*sss_ele_cut
15245             fac=fac+evdwij*sss_ele_grad/rij/expon*(1.0d0-sss)&
15246             -evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15247             ggg(1)=xj*fac
15248             ggg(2)=yj*fac
15249             ggg(3)=zj*fac
15250 ! Uncomment following three lines for SC-p interactions
15251 !           do k=1,3
15252 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15253 !           enddo
15254 ! Uncomment following line for SC-p interactions
15255 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15256             do k=1,3
15257               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15258               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15259             enddo
15260           endif
15261         enddo
15262
15263         enddo ! iint
15264       enddo ! i
15265       do i=1,nct
15266         do j=1,3
15267           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15268           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15269           gradx_scp(j,i)=expon*gradx_scp(j,i)
15270         enddo
15271       enddo
15272 !******************************************************************************
15273 !
15274 !                              N O T E !!!
15275 !
15276 ! To save time the factor EXPON has been extracted from ALL components
15277 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15278 ! use!
15279 !
15280 !******************************************************************************
15281       return
15282       end subroutine escp_long
15283 !-----------------------------------------------------------------------------
15284       subroutine escp_short(evdw2,evdw2_14)
15285 !
15286 ! This subroutine calculates the excluded-volume interaction energy between
15287 ! peptide-group centers and side chains and its gradient in virtual-bond and
15288 ! side-chain vectors.
15289 !
15290 !      implicit real*8 (a-h,o-z)
15291 !      include 'DIMENSIONS'
15292 !      include 'COMMON.GEO'
15293 !      include 'COMMON.VAR'
15294 !      include 'COMMON.LOCAL'
15295 !      include 'COMMON.CHAIN'
15296 !      include 'COMMON.DERIV'
15297 !      include 'COMMON.INTERACT'
15298 !      include 'COMMON.FFIELD'
15299 !      include 'COMMON.IOUNITS'
15300 !      include 'COMMON.CONTROL'
15301       real(kind=8),dimension(3) :: ggg
15302 !el local variables
15303       integer :: i,iint,j,k,iteli,itypj,subchap
15304       real(kind=8) :: xi,yi,zi,xj,yj,zj,rrij,sss,fac,e1,e2,sss_grad,rij
15305       real(kind=8) :: evdw2,evdw2_14,evdwij
15306       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
15307                     dist_temp, dist_init
15308
15309       evdw2=0.0D0
15310       evdw2_14=0.0d0
15311 !d    print '(a)','Enter ESCP'
15312 !d    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
15313       do i=iatscp_s,iatscp_e
15314         if (itype(i,1).eq.ntyp1 .or. itype(i+1,1).eq.ntyp1) cycle
15315         iteli=itel(i)
15316         xi=0.5D0*(c(1,i)+c(1,i+1))
15317         yi=0.5D0*(c(2,i)+c(2,i+1))
15318         zi=0.5D0*(c(3,i)+c(3,i+1))
15319           xi=mod(xi,boxxsize)
15320           if (xi.lt.0) xi=xi+boxxsize
15321           yi=mod(yi,boxysize)
15322           if (yi.lt.0) yi=yi+boxysize
15323           zi=mod(zi,boxzsize)
15324           if (zi.lt.0) zi=zi+boxzsize
15325
15326         do iint=1,nscp_gr(i)
15327
15328         do j=iscpstart(i,iint),iscpend(i,iint)
15329           itypj=itype(j,1)
15330           if (itypj.eq.ntyp1) cycle
15331 ! Uncomment following three lines for SC-p interactions
15332 !         xj=c(1,nres+j)-xi
15333 !         yj=c(2,nres+j)-yi
15334 !         zj=c(3,nres+j)-zi
15335 ! Uncomment following three lines for Ca-p interactions
15336 !          xj=c(1,j)-xi
15337 !          yj=c(2,j)-yi
15338 !          zj=c(3,j)-zi
15339           xj=c(1,j)
15340           yj=c(2,j)
15341           zj=c(3,j)
15342           xj=mod(xj,boxxsize)
15343           if (xj.lt.0) xj=xj+boxxsize
15344           yj=mod(yj,boxysize)
15345           if (yj.lt.0) yj=yj+boxysize
15346           zj=mod(zj,boxzsize)
15347           if (zj.lt.0) zj=zj+boxzsize
15348       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15349       xj_safe=xj
15350       yj_safe=yj
15351       zj_safe=zj
15352       subchap=0
15353       do xshift=-1,1
15354       do yshift=-1,1
15355       do zshift=-1,1
15356           xj=xj_safe+xshift*boxxsize
15357           yj=yj_safe+yshift*boxysize
15358           zj=zj_safe+zshift*boxzsize
15359           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
15360           if(dist_temp.lt.dist_init) then
15361             dist_init=dist_temp
15362             xj_temp=xj
15363             yj_temp=yj
15364             zj_temp=zj
15365             subchap=1
15366           endif
15367        enddo
15368        enddo
15369        enddo
15370        if (subchap.eq.1) then
15371           xj=xj_temp-xi
15372           yj=yj_temp-yi
15373           zj=zj_temp-zi
15374        else
15375           xj=xj_safe-xi
15376           yj=yj_safe-yi
15377           zj=zj_safe-zi
15378        endif
15379
15380           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
15381           rij=dsqrt(1.0d0/rrij)
15382             sss_ele_cut=sscale_ele(rij)
15383             sss_ele_grad=sscagrad_ele(rij)
15384 !            print *,sss_ele_cut,sss_ele_grad,&
15385 !            (rij),r_cut_ele,rlamb_ele
15386             if (sss_ele_cut.le.0.0) cycle
15387           sss=sscale(rij/rscp(itypj,iteli))
15388           sss_grad=sscale_grad(rij/rscp(itypj,iteli))
15389           if (sss.gt.0.0d0) then
15390
15391             fac=rrij**expon2
15392             e1=fac*fac*aad(itypj,iteli)
15393             e2=fac*bad(itypj,iteli)
15394             if (iabs(j-i) .le. 2) then
15395               e1=scal14*e1
15396               e2=scal14*e2
15397               evdw2_14=evdw2_14+(e1+e2)*sss*sss_ele_cut
15398             endif
15399             evdwij=e1+e2
15400             evdw2=evdw2+evdwij*sss*sss_ele_cut
15401             if (energy_dec) write (iout,'(a6,2i5,2(0pf7.3))') &
15402                 'evdw2',i,j,sss,evdwij
15403 !
15404 ! Calculate contributions to the gradient in the virtual-bond and SC vectors.
15405 !
15406             fac=-(evdwij+e1)*rrij*sss*sss_ele_cut
15407             fac=fac+evdwij*sss_ele_grad/rij/expon*sss &
15408             +evdwij*sss_ele_cut/rij/expon*sss_grad/rscp(itypj,iteli)
15409
15410             ggg(1)=xj*fac
15411             ggg(2)=yj*fac
15412             ggg(3)=zj*fac
15413 ! Uncomment following three lines for SC-p interactions
15414 !           do k=1,3
15415 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15416 !           enddo
15417 ! Uncomment following line for SC-p interactions
15418 !             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
15419             do k=1,3
15420               gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
15421               gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
15422             enddo
15423           endif
15424         enddo
15425
15426         enddo ! iint
15427       enddo ! i
15428       do i=1,nct
15429         do j=1,3
15430           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
15431           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
15432           gradx_scp(j,i)=expon*gradx_scp(j,i)
15433         enddo
15434       enddo
15435 !******************************************************************************
15436 !
15437 !                              N O T E !!!
15438 !
15439 ! To save time the factor EXPON has been extracted from ALL components
15440 ! of GVDWC and GRADX. Remember to multiply them by this factor before further
15441 ! use!
15442 !
15443 !******************************************************************************
15444       return
15445       end subroutine escp_short
15446 !-----------------------------------------------------------------------------
15447 ! energy_p_new-sep_barrier.F
15448 !-----------------------------------------------------------------------------
15449       subroutine sc_grad_scale(scalfac)
15450 !      implicit real*8 (a-h,o-z)
15451       use calc_data
15452 !      include 'DIMENSIONS'
15453 !      include 'COMMON.CHAIN'
15454 !      include 'COMMON.DERIV'
15455 !      include 'COMMON.CALC'
15456 !      include 'COMMON.IOUNITS'
15457       real(kind=8),dimension(3) :: dcosom1,dcosom2
15458       real(kind=8) :: scalfac
15459 !el local variables
15460 !      integer :: i,j,k,l
15461
15462       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
15463       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
15464       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
15465            -2.0D0*alf12*eps3der+sigder*sigsq_om12
15466 ! diagnostics only
15467 !      eom1=0.0d0
15468 !      eom2=0.0d0
15469 !      eom12=evdwij*eps1_om12
15470 ! end diagnostics
15471 !      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
15472 !     &  " sigder",sigder
15473 !      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
15474 !      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
15475       do k=1,3
15476         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
15477         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
15478       enddo
15479       do k=1,3
15480         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*scalfac&
15481          *sss_ele_cut
15482       enddo
15483 !      write (iout,*) "gg",(gg(k),k=1,3)
15484       do k=1,3
15485         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
15486                   +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
15487                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*scalfac&
15488                  *sss_ele_cut
15489         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
15490                   +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
15491                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*scalfac&
15492          *sss_ele_cut
15493 !        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
15494 !     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
15495 !        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
15496 !     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
15497       enddo
15498 !
15499 ! Calculate the components of the gradient in DC and X
15500 !
15501       do l=1,3
15502         gvdwc(l,i)=gvdwc(l,i)-gg(l)
15503         gvdwc(l,j)=gvdwc(l,j)+gg(l)
15504       enddo
15505       return
15506       end subroutine sc_grad_scale
15507 !-----------------------------------------------------------------------------
15508 ! energy_split-sep.F
15509 !-----------------------------------------------------------------------------
15510       subroutine etotal_long(energia)
15511 !
15512 ! Compute the long-range slow-varying contributions to the energy
15513 !
15514 !      implicit real*8 (a-h,o-z)
15515 !      include 'DIMENSIONS'
15516       use MD_data, only: totT,usampl,eq_time
15517 #ifndef ISNAN
15518       external proc_proc
15519 #ifdef WINPGI
15520 !MS$ATTRIBUTES C ::  proc_proc
15521 #endif
15522 #endif
15523 #ifdef MPI
15524       include "mpif.h"
15525       real(kind=8),dimension(n_ene) :: weights_!,time_Bcast,time_Bcastw
15526 #endif
15527 !      include 'COMMON.SETUP'
15528 !      include 'COMMON.IOUNITS'
15529 !      include 'COMMON.FFIELD'
15530 !      include 'COMMON.DERIV'
15531 !      include 'COMMON.INTERACT'
15532 !      include 'COMMON.SBRIDGE'
15533 !      include 'COMMON.CHAIN'
15534 !      include 'COMMON.VAR'
15535 !      include 'COMMON.LOCAL'
15536 !      include 'COMMON.MD'
15537       real(kind=8),dimension(0:n_ene) :: energia
15538 !el local variables
15539       integer :: i,n_corr,n_corr1,ierror,ierr
15540       real(kind=8) :: evdw2,evdw2_14,ehpb,etors,edihcnstr,etors_d,esccor,&
15541                   evdw,ees,evdw1,eel_loc,eello_turn3,eello_turn4,&
15542                   ecorr,ecorr5,ecorr6,eturn6,time00
15543 !      write(iout,'(a,i2)')'Calling etotal_long ipot=',ipot
15544 !elwrite(iout,*)"in etotal long"
15545
15546       if (modecalc.eq.12.or.modecalc.eq.14) then
15547 #ifdef MPI
15548 !        if (fg_rank.eq.0) call int_from_cart1(.false.)
15549 #else
15550         call int_from_cart1(.false.)
15551 #endif
15552       endif
15553 !elwrite(iout,*)"in etotal long"
15554
15555 #ifdef MPI
15556 !      write(iout,*) "ETOTAL_LONG Processor",fg_rank,
15557 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15558       call flush(iout)
15559       if (nfgtasks.gt.1) then
15560         time00=MPI_Wtime()
15561 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15562         if (fg_rank.eq.0) then
15563           call MPI_Bcast(3,1,MPI_INTEGER,king,FG_COMM,IERROR)
15564 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15565 !          call flush(iout)
15566 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15567 ! FG slaves as WEIGHTS array.
15568           weights_(1)=wsc
15569           weights_(2)=wscp
15570           weights_(3)=welec
15571           weights_(4)=wcorr
15572           weights_(5)=wcorr5
15573           weights_(6)=wcorr6
15574           weights_(7)=wel_loc
15575           weights_(8)=wturn3
15576           weights_(9)=wturn4
15577           weights_(10)=wturn6
15578           weights_(11)=wang
15579           weights_(12)=wscloc
15580           weights_(13)=wtor
15581           weights_(14)=wtor_d
15582           weights_(15)=wstrain
15583           weights_(16)=wvdwpp
15584           weights_(17)=wbond
15585           weights_(18)=scal14
15586           weights_(21)=wsccor
15587 ! FG Master broadcasts the WEIGHTS_ array
15588           call MPI_Bcast(weights_(1),n_ene,&
15589               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15590         else
15591 ! FG slaves receive the WEIGHTS array
15592           call MPI_Bcast(weights(1),n_ene,&
15593               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15594           wsc=weights(1)
15595           wscp=weights(2)
15596           welec=weights(3)
15597           wcorr=weights(4)
15598           wcorr5=weights(5)
15599           wcorr6=weights(6)
15600           wel_loc=weights(7)
15601           wturn3=weights(8)
15602           wturn4=weights(9)
15603           wturn6=weights(10)
15604           wang=weights(11)
15605           wscloc=weights(12)
15606           wtor=weights(13)
15607           wtor_d=weights(14)
15608           wstrain=weights(15)
15609           wvdwpp=weights(16)
15610           wbond=weights(17)
15611           scal14=weights(18)
15612           wsccor=weights(21)
15613         endif
15614         call MPI_Bcast(dc(1,1),6*nres,MPI_DOUBLE_PRECISION,&
15615           king,FG_COMM,IERR)
15616          time_Bcast=time_Bcast+MPI_Wtime()-time00
15617          time_Bcastw=time_Bcastw+MPI_Wtime()-time00
15618 !        call chainbuild_cart
15619 !        call int_from_cart1(.false.)
15620       endif
15621 !      write (iout,*) 'Processor',myrank,
15622 !     &  ' calling etotal_short ipot=',ipot
15623 !      call flush(iout)
15624 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15625 #endif
15626 !d    print *,'nnt=',nnt,' nct=',nct
15627 !
15628 !elwrite(iout,*)"in etotal long"
15629 ! Compute the side-chain and electrostatic interaction energy
15630 !
15631       goto (101,102,103,104,105,106) ipot
15632 ! Lennard-Jones potential.
15633   101 call elj_long(evdw)
15634 !d    print '(a)','Exit ELJ'
15635       goto 107
15636 ! Lennard-Jones-Kihara potential (shifted).
15637   102 call eljk_long(evdw)
15638       goto 107
15639 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15640   103 call ebp_long(evdw)
15641       goto 107
15642 ! Gay-Berne potential (shifted LJ, angular dependence).
15643   104 call egb_long(evdw)
15644       goto 107
15645 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15646   105 call egbv_long(evdw)
15647       goto 107
15648 ! Soft-sphere potential
15649   106 call e_softsphere(evdw)
15650 !
15651 ! Calculate electrostatic (H-bonding) energy of the main chain.
15652 !
15653   107 continue
15654       call vec_and_deriv
15655       if (ipot.lt.6) then
15656 #ifdef SPLITELE
15657          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or. &
15658              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15659              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15660              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15661 #else
15662          if (welec.gt.0d0.or.wel_loc.gt.0d0.or. &
15663              wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0 &
15664              .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0 &
15665              .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
15666 #endif
15667            call eelec_scale(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
15668          else
15669             ees=0
15670             evdw1=0
15671             eel_loc=0
15672             eello_turn3=0
15673             eello_turn4=0
15674          endif
15675       else
15676 !        write (iout,*) "Soft-spheer ELEC potential"
15677         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,&
15678          eello_turn4)
15679       endif
15680 !
15681 ! Calculate excluded-volume interaction energy between peptide groups
15682 ! and side chains.
15683 !
15684       if (ipot.lt.6) then
15685        if(wscp.gt.0d0) then
15686         call escp_long(evdw2,evdw2_14)
15687        else
15688         evdw2=0
15689         evdw2_14=0
15690        endif
15691       else
15692         call escp_soft_sphere(evdw2,evdw2_14)
15693       endif
15694 !
15695 ! 12/1/95 Multi-body terms
15696 !
15697       n_corr=0
15698       n_corr1=0
15699       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 &
15700           .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
15701          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
15702 !         write (2,*) 'n_corr=',n_corr,' n_corr1=',n_corr1,
15703 !     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
15704       else
15705          ecorr=0.0d0
15706          ecorr5=0.0d0
15707          ecorr6=0.0d0
15708          eturn6=0.0d0
15709       endif
15710       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
15711          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
15712       endif
15713 !
15714 ! If performing constraint dynamics, call the constraint energy
15715 !  after the equilibration time
15716       if(usampl.and.totT.gt.eq_time) then
15717          call EconstrQ
15718          call Econstr_back
15719       else
15720          Uconst=0.0d0
15721          Uconst_back=0.0d0
15722       endif
15723 !
15724 ! Sum the energies
15725 !
15726       do i=1,n_ene
15727         energia(i)=0.0d0
15728       enddo
15729       energia(1)=evdw
15730 #ifdef SCP14
15731       energia(2)=evdw2-evdw2_14
15732       energia(18)=evdw2_14
15733 #else
15734       energia(2)=evdw2
15735       energia(18)=0.0d0
15736 #endif
15737 #ifdef SPLITELE
15738       energia(3)=ees
15739       energia(16)=evdw1
15740 #else
15741       energia(3)=ees+evdw1
15742       energia(16)=0.0d0
15743 #endif
15744       energia(4)=ecorr
15745       energia(5)=ecorr5
15746       energia(6)=ecorr6
15747       energia(7)=eel_loc
15748       energia(8)=eello_turn3
15749       energia(9)=eello_turn4
15750       energia(10)=eturn6
15751       energia(20)=Uconst+Uconst_back
15752       call sum_energy(energia,.true.)
15753 !      write (iout,*) "Exit ETOTAL_LONG"
15754       call flush(iout)
15755       return
15756       end subroutine etotal_long
15757 !-----------------------------------------------------------------------------
15758       subroutine etotal_short(energia)
15759 !
15760 ! Compute the short-range fast-varying contributions to the energy
15761 !
15762 !      implicit real*8 (a-h,o-z)
15763 !      include 'DIMENSIONS'
15764 #ifndef ISNAN
15765       external proc_proc
15766 #ifdef WINPGI
15767 !MS$ATTRIBUTES C ::  proc_proc
15768 #endif
15769 #endif
15770 #ifdef MPI
15771       include "mpif.h"
15772       integer :: ierror,ierr
15773       real(kind=8),dimension(n_ene) :: weights_
15774       real(kind=8) :: time00
15775 #endif
15776 !      include 'COMMON.SETUP'
15777 !      include 'COMMON.IOUNITS'
15778 !      include 'COMMON.FFIELD'
15779 !      include 'COMMON.DERIV'
15780 !      include 'COMMON.INTERACT'
15781 !      include 'COMMON.SBRIDGE'
15782 !      include 'COMMON.CHAIN'
15783 !      include 'COMMON.VAR'
15784 !      include 'COMMON.LOCAL'
15785       real(kind=8),dimension(0:n_ene) :: energia
15786 !el local variables
15787       integer :: i,nres6
15788       real(kind=8) :: evdw,evdw1,evdw2,evdw2_14,esccor,etors_d,etors
15789       real(kind=8) :: ehpb,escloc,estr,ebe,edihcnstr,ethetacnstr
15790       nres6=6*nres
15791
15792 !      write(iout,'(a,i2)')'Calling etotal_short ipot=',ipot
15793 !      call flush(iout)
15794       if (modecalc.eq.12.or.modecalc.eq.14) then
15795 #ifdef MPI
15796         if (fg_rank.eq.0) call int_from_cart1(.false.)
15797 #else
15798         call int_from_cart1(.false.)
15799 #endif
15800       endif
15801 #ifdef MPI
15802 !      write(iout,*) "ETOTAL_SHORT Processor",fg_rank,
15803 !     & " absolute rank",myrank," nfgtasks",nfgtasks
15804 !      call flush(iout)
15805       if (nfgtasks.gt.1) then
15806         time00=MPI_Wtime()
15807 ! FG slaves call the following matching MPI_Bcast in ERGASTULUM
15808         if (fg_rank.eq.0) then
15809           call MPI_Bcast(2,1,MPI_INTEGER,king,FG_COMM,IERROR)
15810 !          write (iout,*) "Processor",myrank," BROADCAST iorder"
15811 !          call flush(iout)
15812 ! FG master sets up the WEIGHTS_ array which will be broadcast to the
15813 ! FG slaves as WEIGHTS array.
15814           weights_(1)=wsc
15815           weights_(2)=wscp
15816           weights_(3)=welec
15817           weights_(4)=wcorr
15818           weights_(5)=wcorr5
15819           weights_(6)=wcorr6
15820           weights_(7)=wel_loc
15821           weights_(8)=wturn3
15822           weights_(9)=wturn4
15823           weights_(10)=wturn6
15824           weights_(11)=wang
15825           weights_(12)=wscloc
15826           weights_(13)=wtor
15827           weights_(14)=wtor_d
15828           weights_(15)=wstrain
15829           weights_(16)=wvdwpp
15830           weights_(17)=wbond
15831           weights_(18)=scal14
15832           weights_(21)=wsccor
15833 ! FG Master broadcasts the WEIGHTS_ array
15834           call MPI_Bcast(weights_(1),n_ene,&
15835               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15836         else
15837 ! FG slaves receive the WEIGHTS array
15838           call MPI_Bcast(weights(1),n_ene,&
15839               MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
15840           wsc=weights(1)
15841           wscp=weights(2)
15842           welec=weights(3)
15843           wcorr=weights(4)
15844           wcorr5=weights(5)
15845           wcorr6=weights(6)
15846           wel_loc=weights(7)
15847           wturn3=weights(8)
15848           wturn4=weights(9)
15849           wturn6=weights(10)
15850           wang=weights(11)
15851           wscloc=weights(12)
15852           wtor=weights(13)
15853           wtor_d=weights(14)
15854           wstrain=weights(15)
15855           wvdwpp=weights(16)
15856           wbond=weights(17)
15857           scal14=weights(18)
15858           wsccor=weights(21)
15859         endif
15860 !        write (iout,*),"Processor",myrank," BROADCAST weights"
15861         call MPI_Bcast(c(1,1),nres6,MPI_DOUBLE_PRECISION,&
15862           king,FG_COMM,IERR)
15863 !        write (iout,*) "Processor",myrank," BROADCAST c"
15864         call MPI_Bcast(dc(1,1),nres6,MPI_DOUBLE_PRECISION,&
15865           king,FG_COMM,IERR)
15866 !        write (iout,*) "Processor",myrank," BROADCAST dc"
15867         call MPI_Bcast(dc_norm(1,1),nres6,MPI_DOUBLE_PRECISION,&
15868           king,FG_COMM,IERR)
15869 !        write (iout,*) "Processor",myrank," BROADCAST dc_norm"
15870         call MPI_Bcast(theta(1),nres,MPI_DOUBLE_PRECISION,&
15871           king,FG_COMM,IERR)
15872 !        write (iout,*) "Processor",myrank," BROADCAST theta"
15873         call MPI_Bcast(phi(1),nres,MPI_DOUBLE_PRECISION,&
15874           king,FG_COMM,IERR)
15875 !        write (iout,*) "Processor",myrank," BROADCAST phi"
15876         call MPI_Bcast(alph(1),nres,MPI_DOUBLE_PRECISION,&
15877           king,FG_COMM,IERR)
15878 !        write (iout,*) "Processor",myrank," BROADCAST alph"
15879         call MPI_Bcast(omeg(1),nres,MPI_DOUBLE_PRECISION,&
15880           king,FG_COMM,IERR)
15881 !        write (iout,*) "Processor",myrank," BROADCAST omeg"
15882         call MPI_Bcast(vbld(1),2*nres,MPI_DOUBLE_PRECISION,&
15883           king,FG_COMM,IERR)
15884 !        write (iout,*) "Processor",myrank," BROADCAST vbld"
15885         call MPI_Bcast(vbld_inv(1),2*nres,MPI_DOUBLE_PRECISION,&
15886           king,FG_COMM,IERR)
15887          time_Bcast=time_Bcast+MPI_Wtime()-time00
15888 !        write (iout,*) "Processor",myrank," BROADCAST vbld_inv"
15889       endif
15890 !      write (iout,*) 'Processor',myrank,
15891 !     &  ' calling etotal_short ipot=',ipot
15892 !      call flush(iout)
15893 !      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
15894 #endif
15895 !      call int_from_cart1(.false.)
15896 !
15897 ! Compute the side-chain and electrostatic interaction energy
15898 !
15899       goto (101,102,103,104,105,106) ipot
15900 ! Lennard-Jones potential.
15901   101 call elj_short(evdw)
15902 !d    print '(a)','Exit ELJ'
15903       goto 107
15904 ! Lennard-Jones-Kihara potential (shifted).
15905   102 call eljk_short(evdw)
15906       goto 107
15907 ! Berne-Pechukas potential (dilated LJ, angular dependence).
15908   103 call ebp_short(evdw)
15909       goto 107
15910 ! Gay-Berne potential (shifted LJ, angular dependence).
15911   104 call egb_short(evdw)
15912       goto 107
15913 ! Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
15914   105 call egbv_short(evdw)
15915       goto 107
15916 ! Soft-sphere potential - already dealt with in the long-range part
15917   106 evdw=0.0d0
15918 !  106 call e_softsphere_short(evdw)
15919 !
15920 ! Calculate electrostatic (H-bonding) energy of the main chain.
15921 !
15922   107 continue
15923 !
15924 ! Calculate the short-range part of Evdwpp
15925 !
15926       call evdwpp_short(evdw1)
15927 !
15928 ! Calculate the short-range part of ESCp
15929 !
15930       if (ipot.lt.6) then
15931         call escp_short(evdw2,evdw2_14)
15932       endif
15933 !
15934 ! Calculate the bond-stretching energy
15935 !
15936       call ebond(estr)
15937 !
15938 ! Calculate the disulfide-bridge and other energy and the contributions
15939 ! from other distance constraints.
15940       call edis(ehpb)
15941 !
15942 ! Calculate the virtual-bond-angle energy.
15943 !
15944       call ebend(ebe,ethetacnstr)
15945 !
15946 ! Calculate the SC local energy.
15947 !
15948       call vec_and_deriv
15949       call esc(escloc)
15950 !
15951 ! Calculate the virtual-bond torsional energy.
15952 !
15953       call etor(etors,edihcnstr)
15954 !
15955 ! 6/23/01 Calculate double-torsional energy
15956 !
15957       call etor_d(etors_d)
15958 !
15959 ! 21/5/07 Calculate local sicdechain correlation energy
15960 !
15961       if (wsccor.gt.0.0d0) then
15962         call eback_sc_corr(esccor)
15963       else
15964         esccor=0.0d0
15965       endif
15966 !
15967 ! Put energy components into an array
15968 !
15969       do i=1,n_ene
15970         energia(i)=0.0d0
15971       enddo
15972       energia(1)=evdw
15973 #ifdef SCP14
15974       energia(2)=evdw2-evdw2_14
15975       energia(18)=evdw2_14
15976 #else
15977       energia(2)=evdw2
15978       energia(18)=0.0d0
15979 #endif
15980 #ifdef SPLITELE
15981       energia(16)=evdw1
15982 #else
15983       energia(3)=evdw1
15984 #endif
15985       energia(11)=ebe
15986       energia(12)=escloc
15987       energia(13)=etors
15988       energia(14)=etors_d
15989       energia(15)=ehpb
15990       energia(17)=estr
15991       energia(19)=edihcnstr
15992       energia(21)=esccor
15993 !      write (iout,*) "ETOTAL_SHORT before SUM_ENERGY"
15994       call flush(iout)
15995       call sum_energy(energia,.true.)
15996 !      write (iout,*) "Exit ETOTAL_SHORT"
15997       call flush(iout)
15998       return
15999       end subroutine etotal_short
16000 !-----------------------------------------------------------------------------
16001 ! gnmr1.f
16002 !-----------------------------------------------------------------------------
16003       real(kind=8) function gnmr1(y,ymin,ymax)
16004 !      implicit none
16005       real(kind=8) :: y,ymin,ymax
16006       real(kind=8) :: wykl=4.0d0
16007       if (y.lt.ymin) then
16008         gnmr1=(ymin-y)**wykl/wykl
16009       else if (y.gt.ymax) then
16010         gnmr1=(y-ymax)**wykl/wykl
16011       else
16012         gnmr1=0.0d0
16013       endif
16014       return
16015       end function gnmr1
16016 !-----------------------------------------------------------------------------
16017       real(kind=8) function gnmr1prim(y,ymin,ymax)
16018 !      implicit none
16019       real(kind=8) :: y,ymin,ymax
16020       real(kind=8) :: wykl=4.0d0
16021       if (y.lt.ymin) then
16022         gnmr1prim=-(ymin-y)**(wykl-1)
16023       else if (y.gt.ymax) then
16024         gnmr1prim=(y-ymax)**(wykl-1)
16025       else
16026         gnmr1prim=0.0d0
16027       endif
16028       return
16029       end function gnmr1prim
16030 !----------------------------------------------------------------------------
16031       real(kind=8) function rlornmr1(y,ymin,ymax,sigma)
16032       real(kind=8) y,ymin,ymax,sigma
16033       real(kind=8) wykl /4.0d0/
16034       if (y.lt.ymin) then
16035         rlornmr1=(ymin-y)**wykl/((ymin-y)**wykl+sigma**wykl)
16036       else if (y.gt.ymax) then
16037         rlornmr1=(y-ymax)**wykl/((y-ymax)**wykl+sigma**wykl)
16038       else
16039         rlornmr1=0.0d0
16040       endif
16041       return
16042       end function rlornmr1
16043 !------------------------------------------------------------------------------
16044       real(kind=8) function rlornmr1prim(y,ymin,ymax,sigma)
16045       real(kind=8) y,ymin,ymax,sigma
16046       real(kind=8) wykl /4.0d0/
16047       if (y.lt.ymin) then
16048         rlornmr1prim=-(ymin-y)**(wykl-1)*sigma**wykl*wykl/ &
16049         ((ymin-y)**wykl+sigma**wykl)**2
16050       else if (y.gt.ymax) then
16051         rlornmr1prim=(y-ymax)**(wykl-1)*sigma**wykl*wykl/ &
16052         ((y-ymax)**wykl+sigma**wykl)**2
16053       else
16054         rlornmr1prim=0.0d0
16055       endif
16056       return
16057       end function rlornmr1prim
16058
16059       real(kind=8) function harmonic(y,ymax)
16060 !      implicit none
16061       real(kind=8) :: y,ymax
16062       real(kind=8) :: wykl=2.0d0
16063       harmonic=(y-ymax)**wykl
16064       return
16065       end function harmonic
16066 !-----------------------------------------------------------------------------
16067       real(kind=8) function harmonicprim(y,ymax)
16068       real(kind=8) :: y,ymin,ymax
16069       real(kind=8) :: wykl=2.0d0
16070       harmonicprim=(y-ymax)*wykl
16071       return
16072       end function harmonicprim
16073 !-----------------------------------------------------------------------------
16074 ! gradient_p.F
16075 !-----------------------------------------------------------------------------
16076       subroutine gradient(n,x,nf,g,uiparm,urparm,ufparm)
16077
16078       use io_base, only:intout,briefout
16079 !      implicit real*8 (a-h,o-z)
16080 !      include 'DIMENSIONS'
16081 !      include 'COMMON.CHAIN'
16082 !      include 'COMMON.DERIV'
16083 !      include 'COMMON.VAR'
16084 !      include 'COMMON.INTERACT'
16085 !      include 'COMMON.FFIELD'
16086 !      include 'COMMON.MD'
16087 !      include 'COMMON.IOUNITS'
16088       real(kind=8),external :: ufparm
16089       integer :: uiparm(1)
16090       real(kind=8) :: urparm(1)
16091       real(kind=8),dimension(6*nres) :: x,g !(maxvar) (maxvar=6*maxres)
16092       real(kind=8) :: f,gthetai,gphii,galphai,gomegai
16093       integer :: n,nf,ind,ind1,i,k,j
16094 !
16095 ! This subroutine calculates total internal coordinate gradient.
16096 ! Depending on the number of function evaluations, either whole energy
16097 ! is evaluated beforehand, Cartesian coordinates and their derivatives in
16098 ! internal coordinates are reevaluated or only the cartesian-in-internal
16099 ! coordinate derivatives are evaluated. The subroutine was designed to work
16100 ! with SUMSL.
16101 !
16102 !
16103       icg=mod(nf,2)+1
16104
16105 !d      print *,'grad',nf,icg
16106       if (nf-nfl+1) 20,30,40
16107    20 call func(n,x,nf,f,uiparm,urparm,ufparm)
16108 !    write (iout,*) 'grad 20'
16109       if (nf.eq.0) return
16110       goto 40
16111    30 call var_to_geom(n,x)
16112       call chainbuild
16113 !    write (iout,*) 'grad 30'
16114 !
16115 ! Evaluate the derivatives of virtual bond lengths and SC vectors in variables.
16116 !
16117    40 call cartder
16118 !     write (iout,*) 'grad 40'
16119 !     print *,'GRADIENT: nnt=',nnt,' nct=',nct,' expon=',expon
16120 !
16121 ! Convert the Cartesian gradient into internal-coordinate gradient.
16122 !
16123       ind=0
16124       ind1=0
16125       do i=1,nres-2
16126       gthetai=0.0D0
16127       gphii=0.0D0
16128       do j=i+1,nres-1
16129           ind=ind+1
16130 !         ind=indmat(i,j)
16131 !         print *,'GRAD: i=',i,' jc=',j,' ind=',ind
16132         do k=1,3
16133             gthetai=gthetai+dcdv(k,ind)*gradc(k,j,icg)
16134           enddo
16135         do k=1,3
16136           gphii=gphii+dcdv(k+3,ind)*gradc(k,j,icg)
16137           enddo
16138         enddo
16139       do j=i+1,nres-1
16140           ind1=ind1+1
16141 !         ind1=indmat(i,j)
16142 !         print *,'GRAD: i=',i,' jx=',j,' ind1=',ind1
16143         do k=1,3
16144           gthetai=gthetai+dxdv(k,ind1)*gradx(k,j,icg)
16145           gphii=gphii+dxdv(k+3,ind1)*gradx(k,j,icg)
16146           enddo
16147         enddo
16148       if (i.gt.1) g(i-1)=gphii
16149       if (n.gt.nphi) g(nphi+i)=gthetai
16150       enddo
16151       if (n.le.nphi+ntheta) goto 10
16152       do i=2,nres-1
16153       if (itype(i,1).ne.10) then
16154           galphai=0.0D0
16155         gomegai=0.0D0
16156         do k=1,3
16157           galphai=galphai+dxds(k,i)*gradx(k,i,icg)
16158           enddo
16159         do k=1,3
16160           gomegai=gomegai+dxds(k+3,i)*gradx(k,i,icg)
16161           enddo
16162           g(ialph(i,1))=galphai
16163         g(ialph(i,1)+nside)=gomegai
16164         endif
16165       enddo
16166 !
16167 ! Add the components corresponding to local energy terms.
16168 !
16169    10 continue
16170       do i=1,nvar
16171 !d      write (iout,*) 'i=',i,'g=',g(i),' gloc=',gloc(i,icg)
16172         g(i)=g(i)+gloc(i,icg)
16173       enddo
16174 ! Uncomment following three lines for diagnostics.
16175 !d    call intout
16176 !elwrite(iout,*) "in gradient after calling intout"
16177 !d    call briefout(0,0.0d0)
16178 !d    write (iout,'(i3,1pe15.5)') (k,g(k),k=1,n)
16179       return
16180       end subroutine gradient
16181 !-----------------------------------------------------------------------------
16182       subroutine func(n,x,nf,f,uiparm,urparm,ufparm) !from minimize_p.F
16183
16184       use comm_chu
16185 !      implicit real*8 (a-h,o-z)
16186 !      include 'DIMENSIONS'
16187 !      include 'COMMON.DERIV'
16188 !      include 'COMMON.IOUNITS'
16189 !      include 'COMMON.GEO'
16190       integer :: n,nf
16191 !el      integer :: jjj
16192 !el      common /chuju/ jjj
16193       real(kind=8) :: energia(0:n_ene)
16194       integer :: uiparm(1)
16195       real(kind=8) :: urparm(1)
16196       real(kind=8) :: f
16197       real(kind=8),external :: ufparm
16198       real(kind=8),dimension(6*nres) :: x      !(maxvar) (maxvar=6*maxres)
16199 !     if (jjj.gt.0) then
16200 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16201 !     endif
16202       nfl=nf
16203       icg=mod(nf,2)+1
16204 !d      print *,'func',nf,nfl,icg
16205       call var_to_geom(n,x)
16206       call zerograd
16207       call chainbuild
16208 !d    write (iout,*) 'ETOTAL called from FUNC'
16209       call etotal(energia)
16210       call sum_gradient
16211       f=energia(0)
16212 !     if (jjj.gt.0) then
16213 !       write (iout,'(10f8.3)') (rad2deg*x(i),i=1,n)
16214 !       write (iout,*) 'f=',etot
16215 !       jjj=0
16216 !     endif
16217       return
16218       end subroutine func
16219 !-----------------------------------------------------------------------------
16220       subroutine cartgrad
16221 !      implicit real*8 (a-h,o-z)
16222 !      include 'DIMENSIONS'
16223       use energy_data
16224       use MD_data, only: totT,usampl,eq_time
16225 #ifdef MPI
16226       include 'mpif.h'
16227 #endif
16228 !      include 'COMMON.CHAIN'
16229 !      include 'COMMON.DERIV'
16230 !      include 'COMMON.VAR'
16231 !      include 'COMMON.INTERACT'
16232 !      include 'COMMON.FFIELD'
16233 !      include 'COMMON.MD'
16234 !      include 'COMMON.IOUNITS'
16235 !      include 'COMMON.TIME1'
16236 !
16237       integer :: i,j
16238
16239 ! This subrouting calculates total Cartesian coordinate gradient.
16240 ! The subroutine chainbuild_cart and energy MUST be called beforehand.
16241 !
16242 !#define DEBUG
16243 #ifdef TIMING
16244       time00=MPI_Wtime()
16245 #endif
16246       icg=1
16247       call sum_gradient
16248 #ifdef TIMING
16249 #endif
16250 !#define DEBUG
16251 !el      write (iout,*) "After sum_gradient"
16252 #ifdef DEBUG
16253 !el      write (iout,*) "After sum_gradient"
16254       do i=1,nres-1
16255         write (iout,*) i," gradc  ",(gradc(j,i,icg),j=1,3)
16256         write (iout,*) i," gradx  ",(gradx(j,i,icg),j=1,3)
16257       enddo
16258 #endif
16259 !#undef DEBUG
16260 ! If performing constraint dynamics, add the gradients of the constraint energy
16261       if(usampl.and.totT.gt.eq_time) then
16262          do i=1,nct
16263            do j=1,3
16264              gradc(j,i,icg)=gradc(j,i,icg)+dudconst(j,i)+duscdiff(j,i)
16265              gradx(j,i,icg)=gradx(j,i,icg)+dudxconst(j,i)+duscdiffx(j,i)
16266            enddo
16267          enddo
16268          do i=1,nres-3
16269            gloc(i,icg)=gloc(i,icg)+dugamma(i)
16270          enddo
16271          do i=1,nres-2
16272            gloc(nphi+i,icg)=gloc(nphi+i,icg)+dutheta(i)
16273          enddo
16274       endif
16275 !elwrite (iout,*) "After sum_gradient"
16276 #ifdef TIMING
16277       time01=MPI_Wtime()
16278 #endif
16279       call intcartderiv
16280 !elwrite (iout,*) "After sum_gradient"
16281 #ifdef TIMING
16282       time_intcartderiv=time_intcartderiv+MPI_Wtime()-time01
16283 #endif
16284 !     call checkintcartgrad
16285 !     write(iout,*) 'calling int_to_cart'
16286 !#define DEBUG
16287 #ifdef DEBUG
16288       write (iout,*) "gcart, gxcart, gloc before int_to_cart"
16289 #endif
16290       do i=0,nct
16291         do j=1,3
16292           gcart(j,i)=gradc(j,i,icg)
16293           gxcart(j,i)=gradx(j,i,icg)
16294 !          if (i.le.2) print *,"gcart_one",gcart(j,i),gradc(j,i,icg)
16295         enddo
16296 #ifdef DEBUG
16297         write (iout,'(i5,2(3f10.5,5x),f10.5)') i,(gcart(j,i),j=1,3),&
16298           (gxcart(j,i),j=1,3),gloc(i,icg)
16299 #endif
16300       enddo
16301 #ifdef TIMING
16302       time01=MPI_Wtime()
16303 #endif
16304 !       print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16305       call int_to_cart
16306 !             print *,"gcart_two",gxcart(2,2),gradx(2,2,icg)
16307
16308 #ifdef TIMING
16309             time_inttocart=time_inttocart+MPI_Wtime()-time01
16310 #endif
16311 #ifdef DEBUG
16312             write (iout,*) "gcart and gxcart after int_to_cart"
16313             do i=0,nres-1
16314             write (iout,'(i5,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3),&
16315                 (gxcart(j,i),j=1,3)
16316             enddo
16317 #endif
16318 !#undef DEBUG
16319 #ifdef CARGRAD
16320 #ifdef DEBUG
16321             write (iout,*) "CARGRAD"
16322 #endif
16323             do i=nres,0,-1
16324             do j=1,3
16325               gcart(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16326       !          gcart_new(j,i)=-gcart(j,i)+gcart(j,i-1)-gxcart(j,i)
16327             enddo
16328       !        write (iout,'(i5,3f10.5,5x,3f10.5,5x,3f10.5)') i,(gcart(j,i),j=1,3), &
16329       !            (gcart_new(j,i),j=1,3),(gxcart(j,i),j=1,3)
16330             enddo
16331       ! Correction: dummy residues
16332             if (nnt.gt.1) then
16333               do j=1,3
16334       !            gcart_new(j,nnt)=gcart_new(j,nnt)+gcart_new(j,1)
16335                 gcart(j,nnt)=gcart(j,nnt)+gcart(j,1)
16336               enddo
16337             endif
16338             if (nct.lt.nres) then
16339               do j=1,3
16340       !            gcart_new(j,nct)=gcart_new(j,nct)+gcart_new(j,nres)
16341                 gcart(j,nct)=gcart(j,nct)+gcart(j,nres)
16342               enddo
16343             endif
16344 #endif
16345 #ifdef TIMING
16346             time_cartgrad=time_cartgrad+MPI_Wtime()-time00
16347 #endif
16348 !#undef DEBUG
16349             return
16350             end subroutine cartgrad
16351       !-----------------------------------------------------------------------------
16352             subroutine zerograd
16353       !      implicit real*8 (a-h,o-z)
16354       !      include 'DIMENSIONS'
16355       !      include 'COMMON.DERIV'
16356       !      include 'COMMON.CHAIN'
16357       !      include 'COMMON.VAR'
16358       !      include 'COMMON.MD'
16359       !      include 'COMMON.SCCOR'
16360       !
16361       !el local variables
16362             integer :: i,j,intertyp,k
16363       ! Initialize Cartesian-coordinate gradient
16364       !
16365       !      if (.not.allocated(gradx)) allocate(gradx(3,nres,2)) !(3,maxres,2)
16366       !      if (.not.allocated(gradc)) allocate(gradc(3,nres,2)) !(3,maxres,2)
16367
16368       !      allocate(gvdwx(3,nres),gvdwc(3,nres),gelc(3,nres),gelc_long(3,nres))
16369       !      allocate(gvdwpp(3,nres),gvdwc_scpp(3,nres),gradx_scp(3,nres))
16370       !      allocate(gvdwc_scp(3,nres),ghpbx(3,nres),ghpbc(3,nres))
16371       !      allocate(gradcorr_long(3,nres))
16372       !      allocate(gradcorr5_long(3,nres),gradcorr6_long(3,nres))
16373       !      allocate(gcorr6_turn_long(3,nres))
16374       !      allocate(gradcorr5(3,nres),gradcorr6(3,nres)) !(3,maxres)
16375
16376       !      if (.not.allocated(gradcorr)) allocate(gradcorr(3,nres)) !(3,maxres)
16377
16378       !      allocate(gel_loc(3,nres),gel_loc_long(3,nres),gcorr3_turn(3,nres))
16379       !      allocate(gcorr4_turn(3,nres),gcorr6_turn(3,nres))
16380
16381       !      if (.not.allocated(gradb)) allocate(gradb(3,nres)) !(3,maxres)
16382       !      if (.not.allocated(gradbx)) allocate(gradbx(3,nres)) !(3,maxres)
16383
16384       !      allocate(gsccorc(3,nres),gsccorx(3,nres)) !(3,maxres)
16385       !      allocate(gscloc(3,nres)) !(3,maxres)
16386       !      if (.not.allocated(gsclocx)) allocate(gsclocx(3,nres)) !(3,maxres)
16387
16388
16389
16390       !      common /deriv_scloc/
16391       !      allocate(dXX_C1tab(3,nres),dYY_C1tab(3,nres),dZZ_C1tab(3,nres))
16392       !      allocate(dXX_Ctab(3,nres),dYY_Ctab(3,nres),dZZ_Ctab(3,nres))
16393       !      allocate(dXX_XYZtab(3,nres),dYY_XYZtab(3,nres),dZZ_XYZtab(3,nres))      !(3,maxres)
16394       !      common /mpgrad/
16395       !      allocate(jgrad_start(nres),jgrad_end(nres)) !(maxres)
16396
16397
16398
16399       !          gradc(j,i,icg)=0.0d0
16400       !          gradx(j,i,icg)=0.0d0
16401
16402       !      allocate(gloc_sc(3,nres,10)) !(3,0:maxres2,10)maxres2=2*maxres
16403       !elwrite(iout,*) "icg",icg
16404             do i=-1,nres
16405             do j=1,3
16406               gvdwx(j,i)=0.0D0
16407               gradx_scp(j,i)=0.0D0
16408               gvdwc(j,i)=0.0D0
16409               gvdwc_scp(j,i)=0.0D0
16410               gvdwc_scpp(j,i)=0.0d0
16411               gelc(j,i)=0.0D0
16412               gelc_long(j,i)=0.0D0
16413               gradb(j,i)=0.0d0
16414               gradbx(j,i)=0.0d0
16415               gvdwpp(j,i)=0.0d0
16416               gel_loc(j,i)=0.0d0
16417               gel_loc_long(j,i)=0.0d0
16418               ghpbc(j,i)=0.0D0
16419               ghpbx(j,i)=0.0D0
16420               gcorr3_turn(j,i)=0.0d0
16421               gcorr4_turn(j,i)=0.0d0
16422               gradcorr(j,i)=0.0d0
16423               gradcorr_long(j,i)=0.0d0
16424               gradcorr5_long(j,i)=0.0d0
16425               gradcorr6_long(j,i)=0.0d0
16426               gcorr6_turn_long(j,i)=0.0d0
16427               gradcorr5(j,i)=0.0d0
16428               gradcorr6(j,i)=0.0d0
16429               gcorr6_turn(j,i)=0.0d0
16430               gsccorc(j,i)=0.0d0
16431               gsccorx(j,i)=0.0d0
16432               gradc(j,i,icg)=0.0d0
16433               gradx(j,i,icg)=0.0d0
16434               gscloc(j,i)=0.0d0
16435               gsclocx(j,i)=0.0d0
16436               gliptran(j,i)=0.0d0
16437               gliptranx(j,i)=0.0d0
16438               gliptranc(j,i)=0.0d0
16439               gshieldx(j,i)=0.0d0
16440               gshieldc(j,i)=0.0d0
16441               gshieldc_loc(j,i)=0.0d0
16442               gshieldx_ec(j,i)=0.0d0
16443               gshieldc_ec(j,i)=0.0d0
16444               gshieldc_loc_ec(j,i)=0.0d0
16445               gshieldx_t3(j,i)=0.0d0
16446               gshieldc_t3(j,i)=0.0d0
16447               gshieldc_loc_t3(j,i)=0.0d0
16448               gshieldx_t4(j,i)=0.0d0
16449               gshieldc_t4(j,i)=0.0d0
16450               gshieldc_loc_t4(j,i)=0.0d0
16451               gshieldx_ll(j,i)=0.0d0
16452               gshieldc_ll(j,i)=0.0d0
16453               gshieldc_loc_ll(j,i)=0.0d0
16454               gg_tube(j,i)=0.0d0
16455               gg_tube_sc(j,i)=0.0d0
16456               gradafm(j,i)=0.0d0
16457               gradb_nucl(j,i)=0.0d0
16458               gradbx_nucl(j,i)=0.0d0
16459               gvdwpp_nucl(j,i)=0.0d0
16460               gvdwpp(j,i)=0.0d0
16461               gelpp(j,i)=0.0d0
16462               gvdwpsb(j,i)=0.0d0
16463               gvdwpsb1(j,i)=0.0d0
16464               gvdwsbc(j,i)=0.0d0
16465               gvdwsbx(j,i)=0.0d0
16466               gelsbc(j,i)=0.0d0
16467               gradcorr_nucl(j,i)=0.0d0
16468               gradcorr3_nucl(j,i)=0.0d0
16469               gradxorr_nucl(j,i)=0.0d0
16470               gradxorr3_nucl(j,i)=0.0d0
16471               gelsbx(j,i)=0.0d0
16472               gsbloc(j,i)=0.0d0
16473               gsblocx(j,i)=0.0d0
16474               gradpepcat(j,i)=0.0d0
16475               gradpepcatx(j,i)=0.0d0
16476               gradcatcat(j,i)=0.0d0
16477               gvdwx_scbase(j,i)=0.0d0
16478               gvdwc_scbase(j,i)=0.0d0
16479               gvdwx_pepbase(j,i)=0.0d0
16480               gvdwc_pepbase(j,i)=0.0d0
16481               gvdwx_scpho(j,i)=0.0d0
16482               gvdwc_scpho(j,i)=0.0d0
16483               gvdwc_peppho(j,i)=0.0d0
16484             enddo
16485              enddo
16486             do i=0,nres
16487             do j=1,3
16488               do intertyp=1,3
16489                gloc_sc(intertyp,i,icg)=0.0d0
16490               enddo
16491             enddo
16492             enddo
16493             do i=1,nres
16494              do j=1,maxcontsshi
16495              shield_list(j,i)=0
16496             do k=1,3
16497       !C           print *,i,j,k
16498                grad_shield_side(k,j,i)=0.0d0
16499                grad_shield_loc(k,j,i)=0.0d0
16500              enddo
16501              enddo
16502              ishield_list(i)=0
16503             enddo
16504
16505       !
16506       ! Initialize the gradient of local energy terms.
16507       !
16508       !      allocate(gloc(4*nres,2))      !!(maxvar,2)(maxvar=6*maxres)
16509       !      if (.not.allocated(gel_loc_loc)) allocate(gel_loc_loc(nres)) !(maxvar)(maxvar=6*maxres)
16510       !      if (.not.allocated(gcorr_loc)) allocate(gcorr_loc(nres)) !(maxvar)(maxvar=6*maxres)
16511       !      allocate(g_corr5_loc(nres),g_corr6_loc(nres))      !(maxvar)(maxvar=6*maxres)
16512       !      allocate(gel_loc_turn3(nres))
16513       !      allocate(gel_loc_turn4(nres),gel_loc_turn6(nres))  !(maxvar)(maxvar=6*maxres)
16514       !      allocate(gsccor_loc(nres))      !(maxres)
16515
16516             do i=1,4*nres
16517             gloc(i,icg)=0.0D0
16518             enddo
16519             do i=1,nres
16520             gel_loc_loc(i)=0.0d0
16521             gcorr_loc(i)=0.0d0
16522             g_corr5_loc(i)=0.0d0
16523             g_corr6_loc(i)=0.0d0
16524             gel_loc_turn3(i)=0.0d0
16525             gel_loc_turn4(i)=0.0d0
16526             gel_loc_turn6(i)=0.0d0
16527             gsccor_loc(i)=0.0d0
16528             enddo
16529       ! initialize gcart and gxcart
16530       !      allocate(gcart(3,0:nres),gxcart(3,0:nres)) !(3,0:MAXRES)
16531             do i=0,nres
16532             do j=1,3
16533               gcart(j,i)=0.0d0
16534               gxcart(j,i)=0.0d0
16535             enddo
16536             enddo
16537             return
16538             end subroutine zerograd
16539       !-----------------------------------------------------------------------------
16540             real(kind=8) function fdum()
16541             fdum=0.0D0
16542             return
16543             end function fdum
16544       !-----------------------------------------------------------------------------
16545       ! intcartderiv.F
16546       !-----------------------------------------------------------------------------
16547             subroutine intcartderiv
16548       !      implicit real*8 (a-h,o-z)
16549       !      include 'DIMENSIONS'
16550 #ifdef MPI
16551             include 'mpif.h'
16552 #endif
16553       !      include 'COMMON.SETUP'
16554       !      include 'COMMON.CHAIN'
16555       !      include 'COMMON.VAR'
16556       !      include 'COMMON.GEO'
16557       !      include 'COMMON.INTERACT'
16558       !      include 'COMMON.DERIV'
16559       !      include 'COMMON.IOUNITS'
16560       !      include 'COMMON.LOCAL'
16561       !      include 'COMMON.SCCOR'
16562             real(kind=8) :: pi4,pi34
16563             real(kind=8),dimension(3,2,nres) :: dcostheta ! (3,2,maxres)
16564             real(kind=8),dimension(3,3,nres) :: dcosphi,dsinphi,dcosalpha,&
16565                       dcosomega,dsinomega !(3,3,maxres)
16566             real(kind=8),dimension(3) :: vo1,vo2,vo3,dummy,vp1,vp2,vp3,vpp1,n
16567
16568             integer :: i,j,k
16569             real(kind=8) :: cost,sint,cost1,sint1,cost2,sint2,sing,cosg,scalp,&
16570                     fac0,fac1,fac2,fac3,fac4,fac5,fac6,ctgt,ctgt1,cosg_inv,&
16571                     fac7,fac8,fac9,scala1,scala2,cosa,sina,sino,fac15,fac16,&
16572                     fac17,coso_inv,fac10,fac11,fac12,fac13,fac14
16573             integer :: nres2
16574             nres2=2*nres
16575
16576       !el from module energy-------------
16577       !el      allocate(dcostau(3,3,3,itau_start:itau_end)) !(3,3,3,maxres2)maxres2=2*maxres
16578       !el      allocate(dsintau(3,3,3,itau_start:itau_end))
16579       !el      allocate(dtauangle(3,3,3,itau_start:itau_end))
16580
16581       !el      allocate(dcostau(3,3,3,0:nres2)) !(3,3,3,maxres2)maxres2=2*maxres
16582       !el      allocate(dsintau(3,3,3,0:nres2))
16583       !el      allocate(dtauangle(3,3,3,0:nres2))
16584       !el      allocate(domicron(3,2,2,0:nres2))
16585       !el      allocate(dcosomicron(3,2,2,0:nres2))
16586
16587
16588
16589 #if defined(MPI) && defined(PARINTDER)
16590             if (nfgtasks.gt.1 .and. me.eq.king) &
16591             call MPI_Bcast(8,1,MPI_INTEGER,king,FG_COMM,IERROR)
16592 #endif
16593             pi4 = 0.5d0*pipol
16594             pi34 = 3*pi4
16595
16596       !      allocate(dtheta(3,2,nres))      !(3,2,maxres)
16597       !      allocate(dphi(3,3,nres),dalpha(3,3,nres),domega(3,3,nres)) !(3,3,maxres)
16598
16599       !     write (iout,*) "iphi1_start",iphi1_start," iphi1_end",iphi1_end
16600             do i=1,nres
16601             do j=1,3
16602               dtheta(j,1,i)=0.0d0
16603               dtheta(j,2,i)=0.0d0
16604               dphi(j,1,i)=0.0d0
16605               dphi(j,2,i)=0.0d0
16606               dphi(j,3,i)=0.0d0
16607             enddo
16608             enddo
16609       ! Derivatives of theta's
16610 #if defined(MPI) && defined(PARINTDER)
16611       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16612             do i=max0(ithet_start-1,3),ithet_end
16613 #else
16614             do i=3,nres
16615 #endif
16616             cost=dcos(theta(i))
16617             sint=sqrt(1-cost*cost)
16618             do j=1,3
16619               dcostheta(j,1,i)=-(dc_norm(j,i-1)+cost*dc_norm(j,i-2))/&
16620               vbld(i-1)
16621               if (itype(i-1,1).ne.ntyp1) dtheta(j,1,i)=-dcostheta(j,1,i)/sint
16622               dcostheta(j,2,i)=-(dc_norm(j,i-2)+cost*dc_norm(j,i-1))/&
16623               vbld(i)
16624               if (itype(i-1,1).ne.ntyp1) dtheta(j,2,i)=-dcostheta(j,2,i)/sint
16625             enddo
16626             enddo
16627 #if defined(MPI) && defined(PARINTDER)
16628       ! We need dtheta(:,:,i-1) to compute dphi(:,:,i)
16629             do i=max0(ithet_start-1,3),ithet_end
16630 #else
16631             do i=3,nres
16632 #endif
16633             if ((itype(i-1,1).ne.10).and.(itype(i-1,1).ne.ntyp1)) then
16634             cost1=dcos(omicron(1,i))
16635             sint1=sqrt(1-cost1*cost1)
16636             cost2=dcos(omicron(2,i))
16637             sint2=sqrt(1-cost2*cost2)
16638              do j=1,3
16639       !C Calculate derivative over first omicron (Cai-2,Cai-1,SCi-1)
16640               dcosomicron(j,1,1,i)=-(dc_norm(j,i-1+nres)+ &
16641               cost1*dc_norm(j,i-2))/ &
16642               vbld(i-1)
16643               domicron(j,1,1,i)=-1.0/sint1*dcosomicron(j,1,1,i)
16644               dcosomicron(j,1,2,i)=-(dc_norm(j,i-2) &
16645               +cost1*(dc_norm(j,i-1+nres)))/ &
16646               vbld(i-1+nres)
16647               domicron(j,1,2,i)=-1.0/sint1*dcosomicron(j,1,2,i)
16648       !C Calculate derivative over second omicron Sci-1,Cai-1 Cai
16649       !C Looks messy but better than if in loop
16650               dcosomicron(j,2,1,i)=-(-dc_norm(j,i-1+nres) &
16651               +cost2*dc_norm(j,i-1))/ &
16652               vbld(i)
16653               domicron(j,2,1,i)=-1.0/sint2*dcosomicron(j,2,1,i)
16654               dcosomicron(j,2,2,i)=-(dc_norm(j,i-1) &
16655                +cost2*(-dc_norm(j,i-1+nres)))/ &
16656               vbld(i-1+nres)
16657       !          write(iout,*) "vbld", i,itype(i,1),vbld(i-1+nres)
16658               domicron(j,2,2,i)=-1.0/sint2*dcosomicron(j,2,2,i)
16659             enddo
16660              endif
16661             enddo
16662       !elwrite(iout,*) "after vbld write"
16663       ! Derivatives of phi:
16664       ! If phi is 0 or 180 degrees, then the formulas
16665       ! have to be derived by power series expansion of the
16666       ! conventional formulas around 0 and 180.
16667 #ifdef PARINTDER
16668             do i=iphi1_start,iphi1_end
16669 #else
16670             do i=4,nres
16671 #endif
16672       !        if (itype(i-1,1).eq.21 .or. itype(i-2,1).eq.21 ) cycle
16673       ! the conventional case
16674             sint=dsin(theta(i))
16675             sint1=dsin(theta(i-1))
16676             sing=dsin(phi(i))
16677             cost=dcos(theta(i))
16678             cost1=dcos(theta(i-1))
16679             cosg=dcos(phi(i))
16680             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1))
16681             fac0=1.0d0/(sint1*sint)
16682             fac1=cost*fac0
16683             fac2=cost1*fac0
16684             fac3=cosg*cost1/(sint1*sint1)
16685             fac4=cosg*cost/(sint*sint)
16686       !    Obtaining the gamma derivatives from sine derivative
16687              if (phi(i).gt.-pi4.and.phi(i).le.pi4.or. &
16688                phi(i).gt.pi34.and.phi(i).le.pi.or. &
16689                phi(i).ge.-pi.and.phi(i).le.-pi34) then
16690              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16691              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1),vp2)
16692              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16693              do j=1,3
16694                 ctgt=cost/sint
16695                 ctgt1=cost1/sint1
16696                 cosg_inv=1.0d0/cosg
16697                 if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16698                 dsinphi(j,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16699                   -(fac0*vp1(j)+sing*dc_norm(j,i-3))*vbld_inv(i-2)
16700                 dphi(j,1,i)=cosg_inv*dsinphi(j,1,i)
16701                 dsinphi(j,2,i)= &
16702                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*dtheta(j,1,i)) &
16703                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16704                 dphi(j,2,i)=cosg_inv*dsinphi(j,2,i)
16705                 dsinphi(j,3,i)=-sing*ctgt*dtheta(j,2,i) &
16706                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16707       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16708                 dphi(j,3,i)=cosg_inv*dsinphi(j,3,i)
16709                 endif
16710       ! Bug fixed 3/24/05 (AL)
16711              enddo
16712       !   Obtaining the gamma derivatives from cosine derivative
16713             else
16714                do j=1,3
16715                if (itype(i-1,1).ne.ntyp1 .and. itype(i-2,1).ne.ntyp1) then
16716                dcosphi(j,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16717                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16718                dc_norm(j,i-3))/vbld(i-2)
16719                dphi(j,1,i)=-1.0/sing*dcosphi(j,1,i)
16720                dcosphi(j,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16721                dcostheta(j,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16722                dcostheta(j,1,i)
16723                dphi(j,2,i)=-1.0/sing*dcosphi(j,2,i)
16724                dcosphi(j,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16725                dcostheta(j,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16726                dc_norm(j,i-1))/vbld(i)
16727                dphi(j,3,i)=-1.0/sing*dcosphi(j,3,i)
16728 !#define DEBUG
16729 #ifdef DEBUG
16730                write(iout,*) "just after",dphi(j,3,i),sing,dcosphi(j,3,i)
16731 #endif
16732 !#undef DEBUG
16733                endif
16734              enddo
16735             endif
16736             enddo
16737       !alculate derivative of Tauangle
16738 #ifdef PARINTDER
16739             do i=itau_start,itau_end
16740 #else
16741             do i=3,nres
16742       !elwrite(iout,*) " vecpr",i,nres
16743 #endif
16744              if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16745       !       if ((itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10).or.
16746       !     &     (itype(i-1,1).eq.ntyp1).or.(itype(i,1).eq.ntyp1)) cycle
16747       !c dtauangle(j,intertyp,dervityp,residue number)
16748       !c INTERTYP=1 SC...Ca...Ca..Ca
16749       ! the conventional case
16750             sint=dsin(theta(i))
16751             sint1=dsin(omicron(2,i-1))
16752             sing=dsin(tauangle(1,i))
16753             cost=dcos(theta(i))
16754             cost1=dcos(omicron(2,i-1))
16755             cosg=dcos(tauangle(1,i))
16756       !elwrite(iout,*) " vecpr5",i,nres
16757             do j=1,3
16758       !elwrite(iout,*) " vecpreee",i,nres,j,i-2+nres
16759       !elwrite(iout,*) " vecpr5",dc_norm2(1,1)
16760             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16761       !       write(iout,*) dc_norm2(j,i-2+nres),"dcnorm"
16762             enddo
16763             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1))
16764             fac0=1.0d0/(sint1*sint)
16765             fac1=cost*fac0
16766             fac2=cost1*fac0
16767             fac3=cosg*cost1/(sint1*sint1)
16768             fac4=cosg*cost/(sint*sint)
16769       !        write(iout,*) "faki",fac0,fac1,fac2,fac3,fac4
16770       !    Obtaining the gamma derivatives from sine derivative
16771              if (tauangle(1,i).gt.-pi4.and.tauangle(1,i).le.pi4.or. &
16772                tauangle(1,i).gt.pi34.and.tauangle(1,i).le.pi.or. &
16773                tauangle(1,i).gt.-pi.and.tauangle(1,i).le.-pi34) then
16774              call vecpr(dc_norm(1,i-1),dc_norm(1,i-2),vp1)
16775              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1),vp2)
16776              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16777             do j=1,3
16778                 ctgt=cost/sint
16779                 ctgt1=cost1/sint1
16780                 cosg_inv=1.0d0/cosg
16781                 dsintau(j,1,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16782              -(fac0*vp1(j)+sing*(dc_norm2(j,i-2+nres))) &
16783              *vbld_inv(i-2+nres)
16784                 dtauangle(j,1,1,i)=cosg_inv*dsintau(j,1,1,i)
16785                 dsintau(j,1,2,i)= &
16786                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*dtheta(j,1,i)) &
16787                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16788       !            write(iout,*) "dsintau", dsintau(j,1,2,i)
16789                 dtauangle(j,1,2,i)=cosg_inv*dsintau(j,1,2,i)
16790       ! Bug fixed 3/24/05 (AL)
16791                 dsintau(j,1,3,i)=-sing*ctgt*dtheta(j,2,i) &
16792                   +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i)
16793       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16794                 dtauangle(j,1,3,i)=cosg_inv*dsintau(j,1,3,i)
16795              enddo
16796       !   Obtaining the gamma derivatives from cosine derivative
16797             else
16798                do j=1,3
16799                dcostau(j,1,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16800                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1)-scalp* &
16801                (dc_norm2(j,i-2+nres)))/vbld(i-2+nres)
16802                dtauangle(j,1,1,i)=-1/sing*dcostau(j,1,1,i)
16803                dcostau(j,1,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16804                dcostheta(j,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16805                dcostheta(j,1,i)
16806                dtauangle(j,1,2,i)=-1/sing*dcostau(j,1,2,i)
16807                dcostau(j,1,3,i)=fac2*dcostheta(j,2,i)+fac4* &
16808                dcostheta(j,2,i)-fac0*(-dc_norm(j,i-2+nres)-scalp* &
16809                dc_norm(j,i-1))/vbld(i)
16810                dtauangle(j,1,3,i)=-1/sing*dcostau(j,1,3,i)
16811       !         write (iout,*) "else",i
16812              enddo
16813             endif
16814       !        do k=1,3
16815       !        write(iout,*) "tu",i,k,(dtauangle(j,1,k,i),j=1,3)
16816       !        enddo
16817             enddo
16818       !C Second case Ca...Ca...Ca...SC
16819 #ifdef PARINTDER
16820             do i=itau_start,itau_end
16821 #else
16822             do i=4,nres
16823 #endif
16824              if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16825               (itype(i-2,1).eq.ntyp1).or.(itype(i-3,1).eq.ntyp1)) cycle
16826       ! the conventional case
16827             sint=dsin(omicron(1,i))
16828             sint1=dsin(theta(i-1))
16829             sing=dsin(tauangle(2,i))
16830             cost=dcos(omicron(1,i))
16831             cost1=dcos(theta(i-1))
16832             cosg=dcos(tauangle(2,i))
16833       !        do j=1,3
16834       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16835       !        enddo
16836             scalp=scalar(dc_norm(1,i-3),dc_norm(1,i-1+nres))
16837             fac0=1.0d0/(sint1*sint)
16838             fac1=cost*fac0
16839             fac2=cost1*fac0
16840             fac3=cosg*cost1/(sint1*sint1)
16841             fac4=cosg*cost/(sint*sint)
16842       !    Obtaining the gamma derivatives from sine derivative
16843              if (tauangle(2,i).gt.-pi4.and.tauangle(2,i).le.pi4.or. &
16844                tauangle(2,i).gt.pi34.and.tauangle(2,i).le.pi.or. &
16845                tauangle(2,i).gt.-pi.and.tauangle(2,i).le.-pi34) then
16846              call vecpr(dc_norm2(1,i-1+nres),dc_norm(1,i-2),vp1)
16847              call vecpr(dc_norm(1,i-3),dc_norm(1,i-1+nres),vp2)
16848              call vecpr(dc_norm(1,i-3),dc_norm(1,i-2),vp3)
16849             do j=1,3
16850                 ctgt=cost/sint
16851                 ctgt1=cost1/sint1
16852                 cosg_inv=1.0d0/cosg
16853                 dsintau(j,2,1,i)=-sing*ctgt1*dtheta(j,1,i-1) &
16854                   +(fac0*vp1(j)-sing*dc_norm(j,i-3))*vbld_inv(i-2)
16855       !       write(iout,*) i,j,dsintau(j,2,1,i),sing*ctgt1*dtheta(j,1,i-1),
16856       !     &fac0*vp1(j),sing*dc_norm(j,i-3),vbld_inv(i-2),"dsintau(2,1)"
16857                 dtauangle(j,2,1,i)=cosg_inv*dsintau(j,2,1,i)
16858                 dsintau(j,2,2,i)= &
16859                   -sing*(ctgt1*dtheta(j,2,i-1)+ctgt*domicron(j,1,1,i)) &
16860                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16861       !            write(iout,*) "sprawdzenie",i,j,sing*ctgt1*dtheta(j,2,i-1),
16862       !     & sing*ctgt*domicron(j,1,2,i),
16863       !     & (fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16864                 dtauangle(j,2,2,i)=cosg_inv*dsintau(j,2,2,i)
16865       ! Bug fixed 3/24/05 (AL)
16866                 dsintau(j,2,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16867                  +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres))*vbld_inv(i-1+nres)
16868       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16869                 dtauangle(j,2,3,i)=cosg_inv*dsintau(j,2,3,i)
16870              enddo
16871       !   Obtaining the gamma derivatives from cosine derivative
16872             else
16873                do j=1,3
16874                dcostau(j,2,1,i)=fac1*dcostheta(j,1,i-1)+fac3* &
16875                dcostheta(j,1,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16876                dc_norm(j,i-3))/vbld(i-2)
16877                dtauangle(j,2,1,i)=-1/sing*dcostau(j,2,1,i)
16878                dcostau(j,2,2,i)=fac1*dcostheta(j,2,i-1)+fac2* &
16879                dcosomicron(j,1,1,i)+fac3*dcostheta(j,2,i-1)+fac4* &
16880                dcosomicron(j,1,1,i)
16881                dtauangle(j,2,2,i)=-1/sing*dcostau(j,2,2,i)
16882                dcostau(j,2,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16883                dcosomicron(j,1,2,i)-fac0*(dc_norm(j,i-3)-scalp* &
16884                dc_norm(j,i-1+nres))/vbld(i-1+nres)
16885                dtauangle(j,2,3,i)=-1/sing*dcostau(j,2,3,i)
16886       !        write(iout,*) i,j,"else", dtauangle(j,2,3,i)
16887              enddo
16888             endif
16889             enddo
16890
16891       !CC third case SC...Ca...Ca...SC
16892 #ifdef PARINTDER
16893
16894             do i=itau_start,itau_end
16895 #else
16896             do i=3,nres
16897 #endif
16898       ! the conventional case
16899             if ((itype(i-1,1).eq.ntyp1).or.(itype(i-1,1).eq.10).or. &
16900             (itype(i-2,1).eq.ntyp1).or.(itype(i-2,1).eq.10)) cycle
16901             sint=dsin(omicron(1,i))
16902             sint1=dsin(omicron(2,i-1))
16903             sing=dsin(tauangle(3,i))
16904             cost=dcos(omicron(1,i))
16905             cost1=dcos(omicron(2,i-1))
16906             cosg=dcos(tauangle(3,i))
16907             do j=1,3
16908             dc_norm2(j,i-2+nres)=-dc_norm(j,i-2+nres)
16909       !        dc_norm2(j,i-1+nres)=-dc_norm(j,i-1+nres)
16910             enddo
16911             scalp=scalar(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres))
16912             fac0=1.0d0/(sint1*sint)
16913             fac1=cost*fac0
16914             fac2=cost1*fac0
16915             fac3=cosg*cost1/(sint1*sint1)
16916             fac4=cosg*cost/(sint*sint)
16917       !    Obtaining the gamma derivatives from sine derivative
16918              if (tauangle(3,i).gt.-pi4.and.tauangle(3,i).le.pi4.or. &
16919                tauangle(3,i).gt.pi34.and.tauangle(3,i).le.pi.or. &
16920                tauangle(3,i).gt.-pi.and.tauangle(3,i).le.-pi34) then
16921              call vecpr(dc_norm(1,i-1+nres),dc_norm(1,i-2),vp1)
16922              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-1+nres),vp2)
16923              call vecpr(dc_norm2(1,i-2+nres),dc_norm(1,i-2),vp3)
16924             do j=1,3
16925                 ctgt=cost/sint
16926                 ctgt1=cost1/sint1
16927                 cosg_inv=1.0d0/cosg
16928                 dsintau(j,3,1,i)=-sing*ctgt1*domicron(j,2,2,i-1) &
16929                   -(fac0*vp1(j)-sing*dc_norm(j,i-2+nres)) &
16930                   *vbld_inv(i-2+nres)
16931                 dtauangle(j,3,1,i)=cosg_inv*dsintau(j,3,1,i)
16932                 dsintau(j,3,2,i)= &
16933                   -sing*(ctgt1*domicron(j,2,1,i-1)+ctgt*domicron(j,1,1,i)) &
16934                   -(fac0*vp2(j)+sing*dc_norm(j,i-2))*vbld_inv(i-1)
16935                 dtauangle(j,3,2,i)=cosg_inv*dsintau(j,3,2,i)
16936       ! Bug fixed 3/24/05 (AL)
16937                 dsintau(j,3,3,i)=-sing*ctgt*domicron(j,1,2,i) &
16938                   +(fac0*vp3(j)-sing*dc_norm(j,i-1+nres)) &
16939                   *vbld_inv(i-1+nres)
16940       !     &        +(fac0*vp3(j)-sing*dc_norm(j,i-1))*vbld_inv(i-1)
16941                 dtauangle(j,3,3,i)=cosg_inv*dsintau(j,3,3,i)
16942              enddo
16943       !   Obtaining the gamma derivatives from cosine derivative
16944             else
16945                do j=1,3
16946                dcostau(j,3,1,i)=fac1*dcosomicron(j,2,2,i-1)+fac3* &
16947                dcosomicron(j,2,2,i-1)-fac0*(dc_norm(j,i-1+nres)-scalp* &
16948                dc_norm2(j,i-2+nres))/vbld(i-2+nres)
16949                dtauangle(j,3,1,i)=-1/sing*dcostau(j,3,1,i)
16950                dcostau(j,3,2,i)=fac1*dcosomicron(j,2,1,i-1)+fac2* &
16951                dcosomicron(j,1,1,i)+fac3*dcosomicron(j,2,1,i-1)+fac4* &
16952                dcosomicron(j,1,1,i)
16953                dtauangle(j,3,2,i)=-1/sing*dcostau(j,3,2,i)
16954                dcostau(j,3,3,i)=fac2*dcosomicron(j,1,2,i)+fac4* &
16955                dcosomicron(j,1,2,i)-fac0*(dc_norm2(j,i-2+nres)-scalp* &
16956                dc_norm(j,i-1+nres))/vbld(i-1+nres)
16957                dtauangle(j,3,3,i)=-1/sing*dcostau(j,3,3,i)
16958       !          write(iout,*) "else",i
16959              enddo
16960             endif
16961             enddo
16962
16963 #ifdef CRYST_SC
16964       !   Derivatives of side-chain angles alpha and omega
16965 #if defined(MPI) && defined(PARINTDER)
16966             do i=ibond_start,ibond_end
16967 #else
16968             do i=2,nres-1
16969 #endif
16970               if(itype(i,1).ne.10 .and. itype(i,1).ne.ntyp1) then
16971                  fac5=1.0d0/dsqrt(2*(1+dcos(theta(i+1))))
16972                  fac6=fac5/vbld(i)
16973                  fac7=fac5*fac5
16974                  fac8=fac5/vbld(i+1)
16975                  fac9=fac5/vbld(i+nres)
16976                  scala1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
16977                  scala2=scalar(dc_norm(1,i),dc_norm(1,i+nres))
16978                  cosa=dsqrt(0.5d0/(1.0d0+dcos(theta(i+1))))* &
16979                  (scalar(dC_norm(1,i),dC_norm(1,i+nres)) &
16980                  -scalar(dC_norm(1,i-1),dC_norm(1,i+nres)))
16981                  sina=sqrt(1-cosa*cosa)
16982                  sino=dsin(omeg(i))
16983       !             write (iout,*) "i",i," cosa",cosa," sina",sina," sino",sino
16984                  do j=1,3
16985                   dcosalpha(j,1,i)=fac6*(scala1*dc_norm(j,i-1)- &
16986                   dc_norm(j,i+nres))-cosa*fac7*dcostheta(j,1,i+1)
16987                   dalpha(j,1,i)=-1/sina*dcosalpha(j,1,i)
16988                   dcosalpha(j,2,i)=fac8*(dc_norm(j,i+nres)- &
16989                   scala2*dc_norm(j,i))-cosa*fac7*dcostheta(j,2,i+1)
16990                   dalpha(j,2,i)=-1/sina*dcosalpha(j,2,i)
16991                   dcosalpha(j,3,i)=(fac9*(dc_norm(j,i)- &
16992                   dc_norm(j,i-1))-(cosa*dc_norm(j,i+nres))/ &
16993                   vbld(i+nres))
16994                   dalpha(j,3,i)=-1/sina*dcosalpha(j,3,i)
16995                 enddo
16996       ! obtaining the derivatives of omega from sines
16997                 if(omeg(i).gt.-pi4.and.omeg(i).le.pi4.or. &
16998                    omeg(i).gt.pi34.and.omeg(i).le.pi.or. &
16999                    omeg(i).gt.-pi.and.omeg(i).le.-pi34) then
17000                    fac15=dcos(theta(i+1))/(dsin(theta(i+1))* &
17001                    dsin(theta(i+1)))
17002                    fac16=dcos(alph(i))/(dsin(alph(i))*dsin(alph(i)))
17003                    fac17=1.0d0/(dsin(theta(i+1))*dsin(alph(i)))
17004                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i),vo1)
17005                    call vecpr(dc_norm(1,i+nres),dc_norm(1,i-1),vo2)
17006                    call vecpr(dc_norm(1,i),dc_norm(1,i-1),vo3)
17007                    coso_inv=1.0d0/dcos(omeg(i))
17008                    do j=1,3
17009                    dsinomega(j,1,i)=sino*(fac15*dcostheta(j,1,i+1) &
17010                    +fac16*dcosalpha(j,1,i))-fac17/vbld(i)*vo1(j)- &
17011                    (sino*dc_norm(j,i-1))/vbld(i)
17012                    domega(j,1,i)=coso_inv*dsinomega(j,1,i)
17013                    dsinomega(j,2,i)=sino*(fac15*dcostheta(j,2,i+1) &
17014                    +fac16*dcosalpha(j,2,i))+fac17/vbld(i+1)*vo2(j) &
17015                    -sino*dc_norm(j,i)/vbld(i+1)
17016                    domega(j,2,i)=coso_inv*dsinomega(j,2,i)
17017                    dsinomega(j,3,i)=sino*fac16*dcosalpha(j,3,i)- &
17018                    fac17/vbld(i+nres)*vo3(j)-sino*dc_norm(j,i+nres)/ &
17019                    vbld(i+nres)
17020                    domega(j,3,i)=coso_inv*dsinomega(j,3,i)
17021                   enddo
17022                else
17023       !   obtaining the derivatives of omega from cosines
17024                  fac10=sqrt(0.5d0*(1-dcos(theta(i+1))))
17025                  fac11=sqrt(0.5d0*(1+dcos(theta(i+1))))
17026                  fac12=fac10*sina
17027                  fac13=fac12*fac12
17028                  fac14=sina*sina
17029                  do j=1,3
17030                   dcosomega(j,1,i)=(-(0.25d0*cosa/fac11* &
17031                   dcostheta(j,1,i+1)+fac11*dcosalpha(j,1,i))*fac12+ &
17032                   (0.25d0/fac10*sina*dcostheta(j,1,i+1)+cosa/sina* &
17033                   fac10*dcosalpha(j,1,i))*(scala2-fac11*cosa))/fac13
17034                   domega(j,1,i)=-1/sino*dcosomega(j,1,i)
17035                   dcosomega(j,2,i)=(((dc_norm(j,i+nres)-scala2* &
17036                   dc_norm(j,i))/vbld(i+1)-0.25d0*cosa/fac11* &
17037                   dcostheta(j,2,i+1)-fac11*dcosalpha(j,2,i))*fac12+ &
17038                   (scala2-fac11*cosa)*(0.25d0*sina/fac10* &
17039                   dcostheta(j,2,i+1)+fac10*cosa/sina*dcosalpha(j,2,i)))/fac13
17040                   domega(j,2,i)=-1/sino*dcosomega(j,2,i)
17041                   dcosomega(j,3,i)=1/fac10*((1/vbld(i+nres)*(dc_norm(j,i)- &
17042                   scala2*dc_norm(j,i+nres))-fac11*dcosalpha(j,3,i))*sina+ &
17043                   (scala2-fac11*cosa)*(cosa/sina*dcosalpha(j,3,i)))/fac14
17044                   domega(j,3,i)=-1/sino*dcosomega(j,3,i)
17045                 enddo
17046               endif
17047              else
17048                do j=1,3
17049                  do k=1,3
17050                    dalpha(k,j,i)=0.0d0
17051                    domega(k,j,i)=0.0d0
17052                  enddo
17053                enddo
17054              endif
17055              enddo
17056 #endif
17057 #if defined(MPI) && defined(PARINTDER)
17058             if (nfgtasks.gt.1) then
17059 #ifdef DEBUG
17060       !d      write (iout,*) "Gather dtheta"
17061       !d      call flush(iout)
17062             write (iout,*) "dtheta before gather"
17063             do i=1,nres
17064             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),k=1,3),j=1,2)
17065             enddo
17066 #endif
17067             call MPI_Gatherv(dtheta(1,1,ithet_start),ithet_count(fg_rank),&
17068             MPI_THET,dtheta(1,1,1),ithet_count(0),ithet_displ(0),MPI_THET,&
17069             king,FG_COMM,IERROR)
17070 !#define DEBUG
17071 #ifdef DEBUG
17072       !d      write (iout,*) "Gather dphi"
17073       !d      call flush(iout)
17074             write (iout,*) "dphi before gather"
17075             do i=1,nres
17076             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),k=1,3),j=1,3)
17077             enddo
17078 #endif
17079 !#undef DEBUG
17080             call MPI_Gatherv(dphi(1,1,iphi1_start),iphi1_count(fg_rank),&
17081             MPI_GAM,dphi(1,1,1),iphi1_count(0),iphi1_displ(0),MPI_GAM,&
17082             king,FG_COMM,IERROR)
17083       !d      write (iout,*) "Gather dalpha"
17084       !d      call flush(iout)
17085 #ifdef CRYST_SC
17086             call MPI_Gatherv(dalpha(1,1,ibond_start),ibond_count(fg_rank),&
17087             MPI_GAM,dalpha(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17088             king,FG_COMM,IERROR)
17089       !d      write (iout,*) "Gather domega"
17090       !d      call flush(iout)
17091             call MPI_Gatherv(domega(1,1,ibond_start),ibond_count(fg_rank),&
17092             MPI_GAM,domega(1,1,1),ibond_count(0),ibond_displ(0),MPI_GAM,&
17093             king,FG_COMM,IERROR)
17094 #endif
17095             endif
17096 #endif
17097 !#define DEBUG
17098 #ifdef DEBUG
17099             write (iout,*) "dtheta after gather"
17100             do i=1,nres
17101             write (iout,'(i3,3(3f8.5,3x))') i,((dtheta(j,k,i),j=1,3),k=1,2)
17102             enddo
17103             write (iout,*) "dphi after gather"
17104             do i=1,nres
17105             write (iout,'(i3,3(3f8.5,3x))') i,((dphi(j,k,i),j=1,3),k=1,3)
17106             enddo
17107             write (iout,*) "dalpha after gather"
17108             do i=1,nres
17109             write (iout,'(i3,3(3f8.5,3x))') i,((dalpha(j,k,i),j=1,3),k=1,3)
17110             enddo
17111             write (iout,*) "domega after gather"
17112             do i=1,nres
17113             write (iout,'(i3,3(3f8.5,3x))') i,((domega(j,k,i),j=1,3),k=1,3)
17114             enddo
17115 #endif
17116 !#undef DEBUG
17117             return
17118             end subroutine intcartderiv
17119       !-----------------------------------------------------------------------------
17120             subroutine checkintcartgrad
17121       !      implicit real*8 (a-h,o-z)
17122       !      include 'DIMENSIONS'
17123 #ifdef MPI
17124             include 'mpif.h'
17125 #endif
17126       !      include 'COMMON.CHAIN'
17127       !      include 'COMMON.VAR'
17128       !      include 'COMMON.GEO'
17129       !      include 'COMMON.INTERACT'
17130       !      include 'COMMON.DERIV'
17131       !      include 'COMMON.IOUNITS'
17132       !      include 'COMMON.SETUP'
17133             real(kind=8),dimension(3,2,nres) :: dthetanum !(3,2,maxres)
17134             real(kind=8),dimension(3,3,nres) :: dphinum,dalphanum,domeganum !(3,3,maxres)
17135             real(kind=8),dimension(nres) :: theta_s,phi_s,alph_s,omeg_s !(maxres)
17136             real(kind=8),dimension(3) :: dc_norm_s
17137             real(kind=8) :: aincr=1.0d-5
17138             integer :: i,j
17139             real(kind=8) :: dcji
17140             do i=1,nres
17141             phi_s(i)=phi(i)
17142             theta_s(i)=theta(i)
17143             alph_s(i)=alph(i)
17144             omeg_s(i)=omeg(i)
17145             enddo
17146       ! Check theta gradient
17147             write (iout,*) &
17148              "Analytical (upper) and numerical (lower) gradient of theta"
17149             write (iout,*)
17150             do i=3,nres
17151             do j=1,3
17152               dcji=dc(j,i-2)
17153               dc(j,i-2)=dcji+aincr
17154               call chainbuild_cart
17155               call int_from_cart1(.false.)
17156           dthetanum(j,1,i)=(theta(i)-theta_s(i))/aincr
17157           dc(j,i-2)=dcji
17158           dcji=dc(j,i-1)
17159           dc(j,i-1)=dc(j,i-1)+aincr
17160           call chainbuild_cart
17161           dthetanum(j,2,i)=(theta(i)-theta_s(i))/aincr
17162           dc(j,i-1)=dcji
17163         enddo
17164 !el        write (iout,'(i5,3f10.5,5x,3f10.5)') i,(dtheta(j,1,i),j=1,3),&
17165 !el          (dtheta(j,2,i),j=1,3)
17166 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') (dthetanum(j,1,i),j=1,3),&
17167 !el          (dthetanum(j,2,i),j=1,3)
17168 !el        write (iout,'(5x,3f10.5,5x,3f10.5)') &
17169 !el          (dthetanum(j,1,i)/dtheta(j,1,i),j=1,3),&
17170 !el          (dthetanum(j,2,i)/dtheta(j,2,i),j=1,3)
17171 !el        write (iout,*)
17172       enddo
17173 ! Check gamma gradient
17174       write (iout,*) &
17175        "Analytical (upper) and numerical (lower) gradient of gamma"
17176       do i=4,nres
17177         do j=1,3
17178           dcji=dc(j,i-3)
17179           dc(j,i-3)=dcji+aincr
17180           call chainbuild_cart
17181           dphinum(j,1,i)=(phi(i)-phi_s(i))/aincr
17182               dc(j,i-3)=dcji
17183           dcji=dc(j,i-2)
17184           dc(j,i-2)=dcji+aincr
17185           call chainbuild_cart
17186           dphinum(j,2,i)=(phi(i)-phi_s(i))/aincr
17187           dc(j,i-2)=dcji
17188           dcji=dc(j,i-1)
17189           dc(j,i-1)=dc(j,i-1)+aincr
17190           call chainbuild_cart
17191           dphinum(j,3,i)=(phi(i)-phi_s(i))/aincr
17192           dc(j,i-1)=dcji
17193         enddo
17194 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dphi(j,1,i),j=1,3),&
17195 !el          (dphi(j,2,i),j=1,3),(dphi(j,3,i),j=1,3)
17196 !el        write (iout,'(5x,3(3f10.5,5x))') (dphinum(j,1,i),j=1,3),&
17197 !el          (dphinum(j,2,i),j=1,3),(dphinum(j,3,i),j=1,3)
17198 !el        write (iout,'(5x,3(3f10.5,5x))') &
17199 !el          (dphinum(j,1,i)/dphi(j,1,i),j=1,3),&
17200 !el          (dphinum(j,2,i)/dphi(j,2,i),j=1,3),&
17201 !el          (dphinum(j,3,i)/dphi(j,3,i),j=1,3)
17202 !el        write (iout,*)
17203       enddo
17204 ! Check alpha gradient
17205       write (iout,*) &
17206        "Analytical (upper) and numerical (lower) gradient of alpha"
17207       do i=2,nres-1
17208        if(itype(i,1).ne.10) then
17209                  do j=1,3
17210                   dcji=dc(j,i-1)
17211                    dc(j,i-1)=dcji+aincr
17212               call chainbuild_cart
17213               dalphanum(j,1,i)=(alph(i)-alph_s(i)) &
17214                  /aincr
17215                   dc(j,i-1)=dcji
17216               dcji=dc(j,i)
17217               dc(j,i)=dcji+aincr
17218               call chainbuild_cart
17219               dalphanum(j,2,i)=(alph(i)-alph_s(i)) &
17220                  /aincr
17221               dc(j,i)=dcji
17222               dcji=dc(j,i+nres)
17223               dc(j,i+nres)=dc(j,i+nres)+aincr
17224               call chainbuild_cart
17225               dalphanum(j,3,i)=(alph(i)-alph_s(i)) &
17226                  /aincr
17227              dc(j,i+nres)=dcji
17228             enddo
17229           endif
17230 !el        write (iout,'(i5,3(3f10.5,5x))') i,(dalpha(j,1,i),j=1,3),&
17231 !el          (dalpha(j,2,i),j=1,3),(dalpha(j,3,i),j=1,3)
17232 !el        write (iout,'(5x,3(3f10.5,5x))') (dalphanum(j,1,i),j=1,3),&
17233 !el          (dalphanum(j,2,i),j=1,3),(dalphanum(j,3,i),j=1,3)
17234 !el        write (iout,'(5x,3(3f10.5,5x))') &
17235 !el          (dalphanum(j,1,i)/dalpha(j,1,i),j=1,3),&
17236 !el          (dalphanum(j,2,i)/dalpha(j,2,i),j=1,3),&
17237 !el          (dalphanum(j,3,i)/dalpha(j,3,i),j=1,3)
17238 !el        write (iout,*)
17239       enddo
17240 !     Check omega gradient
17241       write (iout,*) &
17242        "Analytical (upper) and numerical (lower) gradient of omega"
17243       do i=2,nres-1
17244        if(itype(i,1).ne.10) then
17245                  do j=1,3
17246                   dcji=dc(j,i-1)
17247                    dc(j,i-1)=dcji+aincr
17248               call chainbuild_cart
17249               domeganum(j,1,i)=(omeg(i)-omeg_s(i)) &
17250                  /aincr
17251                   dc(j,i-1)=dcji
17252               dcji=dc(j,i)
17253               dc(j,i)=dcji+aincr
17254               call chainbuild_cart
17255               domeganum(j,2,i)=(omeg(i)-omeg_s(i)) &
17256                  /aincr
17257               dc(j,i)=dcji
17258               dcji=dc(j,i+nres)
17259               dc(j,i+nres)=dc(j,i+nres)+aincr
17260               call chainbuild_cart
17261               domeganum(j,3,i)=(omeg(i)-omeg_s(i)) &
17262                  /aincr
17263              dc(j,i+nres)=dcji
17264             enddo
17265           endif
17266 !el        write (iout,'(i5,3(3f10.5,5x))') i,(domega(j,1,i),j=1,3),&
17267 !el          (domega(j,2,i),j=1,3),(domega(j,3,i),j=1,3)
17268 !el        write (iout,'(5x,3(3f10.5,5x))') (domeganum(j,1,i),j=1,3),&
17269 !el          (domeganum(j,2,i),j=1,3),(domeganum(j,3,i),j=1,3)
17270 !el        write (iout,'(5x,3(3f10.5,5x))') &
17271 !el          (domeganum(j,1,i)/domega(j,1,i),j=1,3),&
17272 !el          (domeganum(j,2,i)/domega(j,2,i),j=1,3),&
17273 !el          (domeganum(j,3,i)/domega(j,3,i),j=1,3)
17274 !el        write (iout,*)
17275       enddo
17276       return
17277       end subroutine checkintcartgrad
17278 !-----------------------------------------------------------------------------
17279 ! q_measure.F
17280 !-----------------------------------------------------------------------------
17281       real(kind=8) function qwolynes(seg1,seg2,flag,seg3,seg4)
17282 !      implicit real*8 (a-h,o-z)
17283 !      include 'DIMENSIONS'
17284 !      include 'COMMON.IOUNITS'
17285 !      include 'COMMON.CHAIN'
17286 !      include 'COMMON.INTERACT'
17287 !      include 'COMMON.VAR'
17288       integer :: i,j,jl,k,l,il,kl,nl,np,ip,kp,seg1,seg2,seg3,seg4,secseg
17289       integer :: kkk,nsep=3
17290       real(kind=8) :: qm      !dist,
17291       real(kind=8) :: qq,qqij,qqijCM,dij,d0ij,dijCM,d0ijCM,qqmax
17292       logical :: lprn=.false.
17293       logical :: flag
17294 !      real(kind=8) :: sigm,x
17295
17296 !el      sigm(x)=0.25d0*x     ! local function
17297       qqmax=1.0d10
17298       do kkk=1,nperm
17299       qq = 0.0d0
17300       nl=0
17301        if(flag) then
17302         do il=seg1+nsep,seg2
17303           do jl=seg1,il-nsep
17304             nl=nl+1
17305             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2 + &
17306                        (cref(2,jl,kkk)-cref(2,il,kkk))**2 + &
17307                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17308             dij=dist(il,jl)
17309             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17310             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17311               nl=nl+1
17312               d0ijCM=dsqrt( &
17313                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17314                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17315                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17316               dijCM=dist(il+nres,jl+nres)
17317               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17318             endif
17319             qq = qq+qqij+qqijCM
17320           enddo
17321         enddo
17322         qq = qq/nl
17323       else
17324       do il=seg1,seg2
17325         if((seg3-il).lt.3) then
17326              secseg=il+3
17327         else
17328              secseg=seg3
17329         endif
17330           do jl=secseg,seg4
17331             nl=nl+1
17332             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17333                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17334                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17335             dij=dist(il,jl)
17336             qqij = dexp(-0.5d0*((dij-d0ij)/(sigm(d0ij)))**2)
17337             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17338               nl=nl+1
17339               d0ijCM=dsqrt( &
17340                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17341                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17342                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17343               dijCM=dist(il+nres,jl+nres)
17344               qqijCM = dexp(-0.5d0*((dijCM-d0ijCM)/(sigm(d0ijCM)))**2)
17345             endif
17346             qq = qq+qqij+qqijCM
17347           enddo
17348         enddo
17349       qq = qq/nl
17350       endif
17351       if (qqmax.le.qq) qqmax=qq
17352       enddo
17353       qwolynes=1.0d0-qqmax
17354       return
17355       end function qwolynes
17356 !-----------------------------------------------------------------------------
17357       subroutine qwolynes_prim(seg1,seg2,flag,seg3,seg4)
17358 !      implicit real*8 (a-h,o-z)
17359 !      include 'DIMENSIONS'
17360 !      include 'COMMON.IOUNITS'
17361 !      include 'COMMON.CHAIN'
17362 !      include 'COMMON.INTERACT'
17363 !      include 'COMMON.VAR'
17364 !      include 'COMMON.MD'
17365       integer :: i,j,jl,k,l,il,nl,seg1,seg2,seg3,seg4,secseg
17366       integer :: nsep=3, kkk
17367 !el      real(kind=8) :: dist
17368       real(kind=8) :: dij,d0ij,dijCM,d0ijCM
17369       logical :: lprn=.false.
17370       logical :: flag
17371       real(kind=8) :: sim,dd0,fac,ddqij
17372 !el      sigm(x)=0.25d0*x           ! local function
17373       do kkk=1,nperm
17374       do i=0,nres
17375         do j=1,3
17376           dqwol(j,i)=0.0d0
17377           dxqwol(j,i)=0.0d0
17378         enddo
17379       enddo
17380       nl=0
17381        if(flag) then
17382         do il=seg1+nsep,seg2
17383           do jl=seg1,il-nsep
17384             nl=nl+1
17385             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17386                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17387                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17388             dij=dist(il,jl)
17389             sim = 1.0d0/sigm(d0ij)
17390             sim = sim*sim
17391             dd0 = dij-d0ij
17392             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17393           do k=1,3
17394               ddqij = (c(k,il)-c(k,jl))*fac
17395               dqwol(k,il)=dqwol(k,il)+ddqij
17396               dqwol(k,jl)=dqwol(k,jl)-ddqij
17397             enddo
17398
17399             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17400               nl=nl+1
17401               d0ijCM=dsqrt( &
17402                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17403                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17404                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17405               dijCM=dist(il+nres,jl+nres)
17406               sim = 1.0d0/sigm(d0ijCM)
17407               sim = sim*sim
17408               dd0=dijCM-d0ijCM
17409               fac=dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17410               do k=1,3
17411                 ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17412                 dxqwol(k,il)=dxqwol(k,il)+ddqij
17413                 dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17414               enddo
17415             endif
17416           enddo
17417         enddo
17418        else
17419         do il=seg1,seg2
17420         if((seg3-il).lt.3) then
17421              secseg=il+3
17422         else
17423              secseg=seg3
17424         endif
17425           do jl=secseg,seg4
17426             nl=nl+1
17427             d0ij=dsqrt((cref(1,jl,kkk)-cref(1,il,kkk))**2+ &
17428                        (cref(2,jl,kkk)-cref(2,il,kkk))**2+ &
17429                        (cref(3,jl,kkk)-cref(3,il,kkk))**2)
17430             dij=dist(il,jl)
17431             sim = 1.0d0/sigm(d0ij)
17432             sim = sim*sim
17433             dd0 = dij-d0ij
17434             fac = dd0*sim/dij*dexp(-0.5d0*dd0*dd0*sim)
17435             do k=1,3
17436               ddqij = (c(k,il)-c(k,jl))*fac
17437               dqwol(k,il)=dqwol(k,il)+ddqij
17438               dqwol(k,jl)=dqwol(k,jl)-ddqij
17439             enddo
17440             if (itype(il,1).ne.10 .or. itype(jl,1).ne.10) then
17441               nl=nl+1
17442               d0ijCM=dsqrt( &
17443                      (cref(1,jl+nres,kkk)-cref(1,il+nres,kkk))**2+ &
17444                      (cref(2,jl+nres,kkk)-cref(2,il+nres,kkk))**2+ &
17445                      (cref(3,jl+nres,kkk)-cref(3,il+nres,kkk))**2)
17446               dijCM=dist(il+nres,jl+nres)
17447               sim = 1.0d0/sigm(d0ijCM)
17448               sim=sim*sim
17449               dd0 = dijCM-d0ijCM
17450               fac = dd0*sim/dijCM*dexp(-0.5d0*dd0*dd0*sim)
17451               do k=1,3
17452                ddqij = (c(k,il+nres)-c(k,jl+nres))*fac
17453                dxqwol(k,il)=dxqwol(k,il)+ddqij
17454                dxqwol(k,jl)=dxqwol(k,jl)-ddqij
17455               enddo
17456             endif
17457           enddo
17458         enddo
17459       endif
17460       enddo
17461        do i=0,nres
17462          do j=1,3
17463            dqwol(j,i)=dqwol(j,i)/nl
17464            dxqwol(j,i)=dxqwol(j,i)/nl
17465          enddo
17466        enddo
17467       return
17468       end subroutine qwolynes_prim
17469 !-----------------------------------------------------------------------------
17470       subroutine qwol_num(seg1,seg2,flag,seg3,seg4)
17471 !      implicit real*8 (a-h,o-z)
17472 !      include 'DIMENSIONS'
17473 !      include 'COMMON.IOUNITS'
17474 !      include 'COMMON.CHAIN'
17475 !      include 'COMMON.INTERACT'
17476 !      include 'COMMON.VAR'
17477       integer :: seg1,seg2,seg3,seg4
17478       logical :: flag
17479       real(kind=8),dimension(3,0:nres) :: qwolan,qwolxan
17480       real(kind=8),dimension(3,0:2*nres) :: cdummy
17481       real(kind=8) :: q1,q2
17482       real(kind=8) :: delta=1.0d-10
17483       integer :: i,j
17484
17485       do i=0,nres
17486         do j=1,3
17487           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17488           cdummy(j,i)=c(j,i)
17489           c(j,i)=c(j,i)+delta
17490           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17491           qwolan(j,i)=(q2-q1)/delta
17492           c(j,i)=cdummy(j,i)
17493         enddo
17494       enddo
17495       do i=0,nres
17496         do j=1,3
17497           q1=qwolynes(seg1,seg2,flag,seg3,seg4)
17498           cdummy(j,i+nres)=c(j,i+nres)
17499           c(j,i+nres)=c(j,i+nres)+delta
17500           q2=qwolynes(seg1,seg2,flag,seg3,seg4)
17501           qwolxan(j,i)=(q2-q1)/delta
17502           c(j,i+nres)=cdummy(j,i+nres)
17503         enddo
17504       enddo
17505 !      write(iout,*) "Numerical Q carteisan gradients backbone: "
17506 !      do i=0,nct
17507 !        write(iout,'(i5,3e15.5)') i, (qwolan(j,i),j=1,3)
17508 !      enddo
17509 !      write(iout,*) "Numerical Q carteisan gradients side-chain: "
17510 !      do i=0,nct
17511 !        write(iout,'(i5,3e15.5)') i, (qwolxan(j,i),j=1,3)
17512 !      enddo
17513       return
17514       end subroutine qwol_num
17515 !-----------------------------------------------------------------------------
17516       subroutine EconstrQ
17517 !     MD with umbrella_sampling using Wolyne's distance measure as a constraint
17518 !      implicit real*8 (a-h,o-z)
17519 !      include 'DIMENSIONS'
17520 !      include 'COMMON.CONTROL'
17521 !      include 'COMMON.VAR'
17522 !      include 'COMMON.MD'
17523       use MD_data
17524 !#ifndef LANG0
17525 !      include 'COMMON.LANGEVIN'
17526 !#else
17527 !      include 'COMMON.LANGEVIN.lang0'
17528 !#endif
17529 !      include 'COMMON.CHAIN'
17530 !      include 'COMMON.DERIV'
17531 !      include 'COMMON.GEO'
17532 !      include 'COMMON.LOCAL'
17533 !      include 'COMMON.INTERACT'
17534 !      include 'COMMON.IOUNITS'
17535 !      include 'COMMON.NAMES'
17536 !      include 'COMMON.TIME1'
17537       real(kind=8) :: uzap1,uzap2,hm1,hm2,hmnum,ucdelan
17538       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy,&
17539                    duconst,duxconst
17540       integer :: kstart,kend,lstart,lend,idummy
17541       real(kind=8) :: delta=1.0d-7
17542       integer :: i,j,k,ii
17543       do i=0,nres
17544          do j=1,3
17545             duconst(j,i)=0.0d0
17546             dudconst(j,i)=0.0d0
17547             duxconst(j,i)=0.0d0
17548             dudxconst(j,i)=0.0d0
17549          enddo
17550       enddo
17551       Uconst=0.0d0
17552       do i=1,nfrag
17553          qfrag(i)=qwolynes(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17554            idummy,idummy)
17555          Uconst=Uconst+wfrag(i,iset)*harmonic(qfrag(i),qinfrag(i,iset))
17556 ! Calculating the derivatives of Constraint energy with respect to Q
17557          Ucdfrag=wfrag(i,iset)*harmonicprim(qfrag(i),&
17558            qinfrag(i,iset))
17559 !         hm1=harmonic(qfrag(i,iset),qinfrag(i,iset))
17560 !             hm2=harmonic(qfrag(i,iset)+delta,qinfrag(i,iset))
17561 !         hmnum=(hm2-hm1)/delta
17562 !         write(iout,*) "harmonicprim frag",harmonicprim(qfrag(i,iset),
17563 !     &   qinfrag(i,iset))
17564 !         write(iout,*) "harmonicnum frag", hmnum
17565 ! Calculating the derivatives of Q with respect to cartesian coordinates
17566          call qwolynes_prim(ifrag(1,i,iset),ifrag(2,i,iset),.true.,&
17567           idummy,idummy)
17568 !         write(iout,*) "dqwol "
17569 !         do ii=1,nres
17570 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17571 !         enddo
17572 !         write(iout,*) "dxqwol "
17573 !         do ii=1,nres
17574 !           write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17575 !         enddo
17576 ! Calculating numerical gradients of dU/dQi and dQi/dxi
17577 !        call qwol_num(ifrag(1,i,iset),ifrag(2,i,iset),.true.
17578 !     &  ,idummy,idummy)
17579 !  The gradients of Uconst in Cs
17580          do ii=0,nres
17581             do j=1,3
17582                duconst(j,ii)=dUconst(j,ii)+ucdfrag*dqwol(j,ii)
17583                dUxconst(j,ii)=dUxconst(j,ii)+ucdfrag*dxqwol(j,ii)
17584             enddo
17585          enddo
17586       enddo
17587       do i=1,npair
17588          kstart=ifrag(1,ipair(1,i,iset),iset)
17589          kend=ifrag(2,ipair(1,i,iset),iset)
17590          lstart=ifrag(1,ipair(2,i,iset),iset)
17591          lend=ifrag(2,ipair(2,i,iset),iset)
17592          qpair(i)=qwolynes(kstart,kend,.false.,lstart,lend)
17593          Uconst=Uconst+wpair(i,iset)*harmonic(qpair(i),qinpair(i,iset))
17594 !  Calculating dU/dQ
17595          Ucdpair=wpair(i,iset)*harmonicprim(qpair(i),qinpair(i,iset))
17596 !         hm1=harmonic(qpair(i),qinpair(i,iset))
17597 !             hm2=harmonic(qpair(i)+delta,qinpair(i,iset))
17598 !         hmnum=(hm2-hm1)/delta
17599 !         write(iout,*) "harmonicprim pair ",harmonicprim(qpair(i),
17600 !     &   qinpair(i,iset))
17601 !         write(iout,*) "harmonicnum pair ", hmnum
17602 ! Calculating dQ/dXi
17603          call qwolynes_prim(kstart,kend,.false.,&
17604           lstart,lend)
17605 !         write(iout,*) "dqwol "
17606 !         do ii=1,nres
17607 !          write(iout,'(i5,3e15.5)') ii,(dqwol(j,ii),j=1,3)
17608 !         enddo
17609 !         write(iout,*) "dxqwol "
17610 !         do ii=1,nres
17611 !          write(iout,'(i5,3e15.5)') ii,(dxqwol(j,ii),j=1,3)
17612 !        enddo
17613 ! Calculating numerical gradients
17614 !        call qwol_num(kstart,kend,.false.
17615 !     &  ,lstart,lend)
17616 ! The gradients of Uconst in Cs
17617          do ii=0,nres
17618             do j=1,3
17619                duconst(j,ii)=dUconst(j,ii)+ucdpair*dqwol(j,ii)
17620                dUxconst(j,ii)=dUxconst(j,ii)+ucdpair*dxqwol(j,ii)
17621             enddo
17622          enddo
17623       enddo
17624 !      write(iout,*) "Uconst inside subroutine ", Uconst
17625 ! Transforming the gradients from Cs to dCs for the backbone
17626       do i=0,nres
17627          do j=i+1,nres
17628            do k=1,3
17629              dudconst(k,i)=dudconst(k,i)+duconst(k,j)+duxconst(k,j)
17630            enddo
17631          enddo
17632       enddo
17633 !  Transforming the gradients from Cs to dCs for the side chains
17634       do i=1,nres
17635          do j=1,3
17636            dudxconst(j,i)=duxconst(j,i)
17637          enddo
17638       enddo
17639 !      write(iout,*) "dU/ddc backbone "
17640 !       do ii=0,nres
17641 !        write(iout,'(i5,3e15.5)') ii, (dudconst(j,ii),j=1,3)
17642 !      enddo
17643 !      write(iout,*) "dU/ddX side chain "
17644 !      do ii=1,nres
17645 !            write(iout,'(i5,3e15.5)') ii,(duxconst(j,ii),j=1,3)
17646 !      enddo
17647 ! Calculating numerical gradients of dUconst/ddc and dUconst/ddx
17648 !      call dEconstrQ_num
17649       return
17650       end subroutine EconstrQ
17651 !-----------------------------------------------------------------------------
17652       subroutine dEconstrQ_num
17653 ! Calculating numerical dUconst/ddc and dUconst/ddx
17654 !      implicit real*8 (a-h,o-z)
17655 !      include 'DIMENSIONS'
17656 !      include 'COMMON.CONTROL'
17657 !      include 'COMMON.VAR'
17658 !      include 'COMMON.MD'
17659       use MD_data
17660 !#ifndef LANG0
17661 !      include 'COMMON.LANGEVIN'
17662 !#else
17663 !      include 'COMMON.LANGEVIN.lang0'
17664 !#endif
17665 !      include 'COMMON.CHAIN'
17666 !      include 'COMMON.DERIV'
17667 !      include 'COMMON.GEO'
17668 !      include 'COMMON.LOCAL'
17669 !      include 'COMMON.INTERACT'
17670 !      include 'COMMON.IOUNITS'
17671 !      include 'COMMON.NAMES'
17672 !      include 'COMMON.TIME1'
17673       real(kind=8) :: uzap1,uzap2
17674       real(kind=8),dimension(3,0:nres) :: dUcartan,dUxcartan,cdummy
17675       integer :: kstart,kend,lstart,lend,idummy
17676       real(kind=8) :: delta=1.0d-7
17677 !el local variables
17678       integer :: i,ii,j
17679 !     real(kind=8) ::
17680 !     For the backbone
17681       do i=0,nres-1
17682          do j=1,3
17683             dUcartan(j,i)=0.0d0
17684             cdummy(j,i)=dc(j,i)
17685             dc(j,i)=dc(j,i)+delta
17686             call chainbuild_cart
17687           uzap2=0.0d0
17688             do ii=1,nfrag
17689              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17690                 idummy,idummy)
17691                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17692                 qinfrag(ii,iset))
17693             enddo
17694             do ii=1,npair
17695                kstart=ifrag(1,ipair(1,ii,iset),iset)
17696                kend=ifrag(2,ipair(1,ii,iset),iset)
17697                lstart=ifrag(1,ipair(2,ii,iset),iset)
17698                lend=ifrag(2,ipair(2,ii,iset),iset)
17699                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17700                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17701                  qinpair(ii,iset))
17702             enddo
17703             dc(j,i)=cdummy(j,i)
17704             call chainbuild_cart
17705             uzap1=0.0d0
17706              do ii=1,nfrag
17707              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17708                 idummy,idummy)
17709                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17710                 qinfrag(ii,iset))
17711             enddo
17712             do ii=1,npair
17713                kstart=ifrag(1,ipair(1,ii,iset),iset)
17714                kend=ifrag(2,ipair(1,ii,iset),iset)
17715                lstart=ifrag(1,ipair(2,ii,iset),iset)
17716                lend=ifrag(2,ipair(2,ii,iset),iset)
17717                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17718                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17719                 qinpair(ii,iset))
17720             enddo
17721             ducartan(j,i)=(uzap2-uzap1)/(delta)
17722          enddo
17723       enddo
17724 ! Calculating numerical gradients for dU/ddx
17725       do i=0,nres-1
17726          duxcartan(j,i)=0.0d0
17727          do j=1,3
17728             cdummy(j,i)=dc(j,i+nres)
17729             dc(j,i+nres)=dc(j,i+nres)+delta
17730             call chainbuild_cart
17731           uzap2=0.0d0
17732             do ii=1,nfrag
17733              qfrag(ii)=qwolynes(ifrag(1,ii,iset),ifrag(2,ii,iset),.true.,&
17734                 idummy,idummy)
17735                uzap2=uzap2+wfrag(ii,iset)*harmonic(qfrag(ii),&
17736                 qinfrag(ii,iset))
17737             enddo
17738             do ii=1,npair
17739                kstart=ifrag(1,ipair(1,ii,iset),iset)
17740                kend=ifrag(2,ipair(1,ii,iset),iset)
17741                lstart=ifrag(1,ipair(2,ii,iset),iset)
17742                lend=ifrag(2,ipair(2,ii,iset),iset)
17743                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17744                uzap2=uzap2+wpair(ii,iset)*harmonic(qpair(ii),&
17745                 qinpair(ii,iset))
17746             enddo
17747             dc(j,i+nres)=cdummy(j,i)
17748             call chainbuild_cart
17749             uzap1=0.0d0
17750              do ii=1,nfrag
17751                qfrag(ii)=qwolynes(ifrag(1,ii,iset),&
17752                 ifrag(2,ii,iset),.true.,idummy,idummy)
17753                uzap1=uzap1+wfrag(ii,iset)*harmonic(qfrag(ii),&
17754                 qinfrag(ii,iset))
17755             enddo
17756             do ii=1,npair
17757                kstart=ifrag(1,ipair(1,ii,iset),iset)
17758                kend=ifrag(2,ipair(1,ii,iset),iset)
17759                lstart=ifrag(1,ipair(2,ii,iset),iset)
17760                lend=ifrag(2,ipair(2,ii,iset),iset)
17761                qpair(ii)=qwolynes(kstart,kend,.false.,lstart,lend)
17762                uzap1=uzap1+wpair(ii,iset)*harmonic(qpair(ii),&
17763                 qinpair(ii,iset))
17764             enddo
17765             duxcartan(j,i)=(uzap2-uzap1)/(delta)
17766          enddo
17767       enddo
17768       write(iout,*) "Numerical dUconst/ddc backbone "
17769       do ii=0,nres
17770         write(iout,'(i5,3e15.5)') ii,(dUcartan(j,ii),j=1,3)
17771       enddo
17772 !      write(iout,*) "Numerical dUconst/ddx side-chain "
17773 !      do ii=1,nres
17774 !         write(iout,'(i5,3e15.5)') ii,(dUxcartan(j,ii),j=1,3)
17775 !      enddo
17776       return
17777       end subroutine dEconstrQ_num
17778 !-----------------------------------------------------------------------------
17779 ! ssMD.F
17780 !-----------------------------------------------------------------------------
17781       subroutine check_energies
17782
17783 !      use random, only: ran_number
17784
17785 !      implicit none
17786 !     Includes
17787 !      include 'DIMENSIONS'
17788 !      include 'COMMON.CHAIN'
17789 !      include 'COMMON.VAR'
17790 !      include 'COMMON.IOUNITS'
17791 !      include 'COMMON.SBRIDGE'
17792 !      include 'COMMON.LOCAL'
17793 !      include 'COMMON.GEO'
17794
17795 !     External functions
17796 !EL      double precision ran_number
17797 !EL      external ran_number
17798
17799 !     Local variables
17800       integer :: i,j,k,l,lmax,p,pmax
17801       real(kind=8) :: rmin,rmax
17802       real(kind=8) :: eij
17803
17804       real(kind=8) :: d
17805       real(kind=8) :: wi,rij,tj,pj
17806 !      return
17807
17808       i=5
17809       j=14
17810
17811       d=dsc(1)
17812       rmin=2.0D0
17813       rmax=12.0D0
17814
17815       lmax=10000
17816       pmax=1
17817
17818       do k=1,3
17819         c(k,i)=0.0D0
17820         c(k,j)=0.0D0
17821         c(k,nres+i)=0.0D0
17822         c(k,nres+j)=0.0D0
17823       enddo
17824
17825       do l=1,lmax
17826
17827 !t        wi=ran_number(0.0D0,pi)
17828 !        wi=ran_number(0.0D0,pi/6.0D0)
17829 !        wi=0.0D0
17830 !t        tj=ran_number(0.0D0,pi)
17831 !t        pj=ran_number(0.0D0,pi)
17832 !        pj=ran_number(0.0D0,pi/6.0D0)
17833 !        pj=0.0D0
17834
17835         do p=1,pmax
17836 !t           rij=ran_number(rmin,rmax)
17837
17838            c(1,j)=d*sin(pj)*cos(tj)
17839            c(2,j)=d*sin(pj)*sin(tj)
17840            c(3,j)=d*cos(pj)
17841
17842            c(3,nres+i)=-rij
17843
17844            c(1,i)=d*sin(wi)
17845            c(3,i)=-rij-d*cos(wi)
17846
17847            do k=1,3
17848               dc(k,nres+i)=c(k,nres+i)-c(k,i)
17849               dc_norm(k,nres+i)=dc(k,nres+i)/d
17850               dc(k,nres+j)=c(k,nres+j)-c(k,j)
17851               dc_norm(k,nres+j)=dc(k,nres+j)/d
17852            enddo
17853
17854            call dyn_ssbond_ene(i,j,eij)
17855         enddo
17856       enddo
17857       call exit(1)
17858       return
17859       end subroutine check_energies
17860 !-----------------------------------------------------------------------------
17861       subroutine dyn_ssbond_ene(resi,resj,eij)
17862 !      implicit none
17863 !      Includes
17864       use calc_data
17865       use comm_sschecks
17866 !      include 'DIMENSIONS'
17867 !      include 'COMMON.SBRIDGE'
17868 !      include 'COMMON.CHAIN'
17869 !      include 'COMMON.DERIV'
17870 !      include 'COMMON.LOCAL'
17871 !      include 'COMMON.INTERACT'
17872 !      include 'COMMON.VAR'
17873 !      include 'COMMON.IOUNITS'
17874 !      include 'COMMON.CALC'
17875 #ifndef CLUST
17876 #ifndef WHAM
17877        use MD_data
17878 !      include 'COMMON.MD'
17879 !      use MD, only: totT,t_bath
17880 #endif
17881 #endif
17882 !     External functions
17883 !EL      double precision h_base
17884 !EL      external h_base
17885
17886 !     Input arguments
17887       integer :: resi,resj
17888
17889 !     Output arguments
17890       real(kind=8) :: eij
17891
17892 !     Local variables
17893       logical :: havebond
17894       integer itypi,itypj
17895       real(kind=8) :: rrij,ssd,deltat1,deltat2,deltat12,cosphi
17896       real(kind=8) :: sig0ij,ljd,sig,fac,e1,e2
17897       real(kind=8),dimension(3) :: dcosom1,dcosom2
17898       real(kind=8) :: ed
17899       real(kind=8) :: pom1,pom2
17900       real(kind=8) :: ljA,ljB,ljXs
17901       real(kind=8),dimension(1:3) :: d_ljB
17902       real(kind=8) :: ssA,ssB,ssC,ssXs
17903       real(kind=8) :: ssxm,ljxm,ssm,ljm
17904       real(kind=8),dimension(1:3) :: d_ssxm,d_ljxm,d_ssm,d_ljm
17905       real(kind=8) :: f1,f2,h1,h2,hd1,hd2
17906       real(kind=8) :: omega,delta_inv,deltasq_inv,fac1,fac2
17907 !-------FIRST METHOD
17908       real(kind=8) :: xm
17909       real(kind=8),dimension(1:3) :: d_xm
17910 !-------END FIRST METHOD
17911 !-------SECOND METHOD
17912 !$$$      double precision ss,d_ss(0:3),ljf,d_ljf(0:3)
17913 !-------END SECOND METHOD
17914
17915 !-------TESTING CODE
17916 !el      logical :: checkstop,transgrad
17917 !el      common /sschecks/ checkstop,transgrad
17918
17919       integer :: icheck,nicheck,jcheck,njcheck
17920       real(kind=8),dimension(-1:1) :: echeck
17921       real(kind=8) :: deps,ssx0,ljx0
17922 !-------END TESTING CODE
17923
17924       eij=0.0d0
17925       i=resi
17926       j=resj
17927
17928 !el      allocate(dyn_ssbond_ij(iatsc_s:iatsc_e,nres))
17929 !el      allocate(dyn_ssbond_ij(0:nres+4,nres))
17930
17931       itypi=itype(i,1)
17932       dxi=dc_norm(1,nres+i)
17933       dyi=dc_norm(2,nres+i)
17934       dzi=dc_norm(3,nres+i)
17935       dsci_inv=vbld_inv(i+nres)
17936
17937       itypj=itype(j,1)
17938       xj=c(1,nres+j)-c(1,nres+i)
17939       yj=c(2,nres+j)-c(2,nres+i)
17940       zj=c(3,nres+j)-c(3,nres+i)
17941       dxj=dc_norm(1,nres+j)
17942       dyj=dc_norm(2,nres+j)
17943       dzj=dc_norm(3,nres+j)
17944       dscj_inv=vbld_inv(j+nres)
17945
17946       chi1=chi(itypi,itypj)
17947       chi2=chi(itypj,itypi)
17948       chi12=chi1*chi2
17949       chip1=chip(itypi)
17950       chip2=chip(itypj)
17951       chip12=chip1*chip2
17952       alf1=alp(itypi)
17953       alf2=alp(itypj)
17954       alf12=0.5D0*(alf1+alf2)
17955
17956       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
17957       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
17958 !     The following are set in sc_angular
17959 !      erij(1)=xj*rij
17960 !      erij(2)=yj*rij
17961 !      erij(3)=zj*rij
17962 !      om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
17963 !      om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
17964 !      om12=dxi*dxj+dyi*dyj+dzi*dzj
17965       call sc_angular
17966       rij=1.0D0/rij  ! Reset this so it makes sense
17967
17968       sig0ij=sigma(itypi,itypj)
17969       sig=sig0ij*dsqrt(1.0D0/sigsq)
17970
17971       ljXs=sig-sig0ij
17972       ljA=eps1*eps2rt**2*eps3rt**2
17973       ljB=ljA*bb_aq(itypi,itypj)
17974       ljA=ljA*aa_aq(itypi,itypj)
17975       ljxm=ljXs+(-2.0D0*aa_aq(itypi,itypj)/bb_aq(itypi,itypj))**(1.0D0/6.0D0)
17976
17977       ssXs=d0cm
17978       deltat1=1.0d0-om1
17979       deltat2=1.0d0+om2
17980       deltat12=om2-om1+2.0d0
17981       cosphi=om12-om1*om2
17982       ssA=akcm
17983       ssB=akct*deltat12
17984       ssC=ss_depth &
17985            +akth*(deltat1*deltat1+deltat2*deltat2) &
17986            +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
17987       ssxm=ssXs-0.5D0*ssB/ssA
17988
17989 !-------TESTING CODE
17990 !$$$c     Some extra output
17991 !$$$      ssm=ssC-0.25D0*ssB*ssB/ssA
17992 !$$$      ljm=-0.25D0*ljB*bb(itypi,itypj)/aa(itypi,itypj)
17993 !$$$      ssx0=ssB*ssB-4.0d0*ssA*ssC
17994 !$$$      if (ssx0.gt.0.0d0) then
17995 !$$$        ssx0=ssXs+0.5d0*(-ssB+sqrt(ssx0))/ssA
17996 !$$$      else
17997 !$$$        ssx0=ssxm
17998 !$$$      endif
17999 !$$$      ljx0=ljXs+(-aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
18000 !$$$      write(iout,'(a,4f8.2,2f15.2,3f6.2)')"SSENERGIES ",
18001 !$$$     &     ssxm,ljxm,ssx0,ljx0,ssm,ljm,om1,om2,om12
18002 !$$$      return
18003 !-------END TESTING CODE
18004
18005 !-------TESTING CODE
18006 !     Stop and plot energy and derivative as a function of distance
18007       if (checkstop) then
18008         ssm=ssC-0.25D0*ssB*ssB/ssA
18009         ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18010         if (ssm.lt.ljm .and. &
18011              dabs(rij-0.5d0*(ssxm+ljxm)).lt.0.35d0*(ljxm-ssxm)) then
18012           nicheck=1000
18013           njcheck=1
18014           deps=0.5d-7
18015         else
18016           checkstop=.false.
18017         endif
18018       endif
18019       if (.not.checkstop) then
18020         nicheck=0
18021         njcheck=-1
18022       endif
18023
18024       do icheck=0,nicheck
18025       do jcheck=-1,njcheck
18026       if (checkstop) rij=(ssxm-1.0d0)+ &
18027              ((ljxm-ssxm+2.0d0)*icheck)/nicheck+jcheck*deps
18028 !-------END TESTING CODE
18029
18030       if (rij.gt.ljxm) then
18031         havebond=.false.
18032         ljd=rij-ljXs
18033         fac=(1.0D0/ljd)**expon
18034         e1=fac*fac*aa_aq(itypi,itypj)
18035         e2=fac*bb_aq(itypi,itypj)
18036         eij=eps1*eps2rt*eps3rt*(e1+e2)
18037         eps2der=eij*eps3rt
18038         eps3der=eij*eps2rt
18039         eij=eij*eps2rt*eps3rt
18040
18041         sigder=-sig/sigsq
18042         e1=e1*eps1*eps2rt**2*eps3rt**2
18043         ed=-expon*(e1+eij)/ljd
18044         sigder=ed*sigder
18045         eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
18046         eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
18047         eom12=eij*eps1_om12+eps2der*eps2rt_om12 &
18048              -2.0D0*alf12*eps3der+sigder*sigsq_om12
18049       else if (rij.lt.ssxm) then
18050         havebond=.true.
18051         ssd=rij-ssXs
18052         eij=ssA*ssd*ssd+ssB*ssd+ssC
18053
18054         ed=2*akcm*ssd+akct*deltat12
18055         pom1=akct*ssd
18056         pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
18057         eom1=-2*akth*deltat1-pom1-om2*pom2
18058         eom2= 2*akth*deltat2+pom1-om1*pom2
18059         eom12=pom2
18060       else
18061         omega=v1ss+2.0d0*v2ss*cosphi+3.0d0*v3ss*cosphi*cosphi
18062
18063         d_ssxm(1)=0.5D0*akct/ssA
18064         d_ssxm(2)=-d_ssxm(1)
18065         d_ssxm(3)=0.0D0
18066
18067         d_ljxm(1)=sig0ij/sqrt(sigsq**3)
18068         d_ljxm(2)=d_ljxm(1)*sigsq_om2
18069         d_ljxm(3)=d_ljxm(1)*sigsq_om12
18070         d_ljxm(1)=d_ljxm(1)*sigsq_om1
18071
18072 !-------FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18073         xm=0.5d0*(ssxm+ljxm)
18074         do k=1,3
18075           d_xm(k)=0.5d0*(d_ssxm(k)+d_ljxm(k))
18076         enddo
18077         if (rij.lt.xm) then
18078           havebond=.true.
18079           ssm=ssC-0.25D0*ssB*ssB/ssA
18080           d_ssm(1)=0.5D0*akct*ssB/ssA
18081           d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18082           d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18083           d_ssm(3)=omega
18084           f1=(rij-xm)/(ssxm-xm)
18085           f2=(rij-ssxm)/(xm-ssxm)
18086           h1=h_base(f1,hd1)
18087           h2=h_base(f2,hd2)
18088           eij=ssm*h1+Ht*h2
18089           delta_inv=1.0d0/(xm-ssxm)
18090           deltasq_inv=delta_inv*delta_inv
18091           fac=ssm*hd1-Ht*hd2
18092           fac1=deltasq_inv*fac*(xm-rij)
18093           fac2=deltasq_inv*fac*(rij-ssxm)
18094           ed=delta_inv*(Ht*hd2-ssm*hd1)
18095           eom1=fac1*d_ssxm(1)+fac2*d_xm(1)+h1*d_ssm(1)
18096           eom2=fac1*d_ssxm(2)+fac2*d_xm(2)+h1*d_ssm(2)
18097           eom12=fac1*d_ssxm(3)+fac2*d_xm(3)+h1*d_ssm(3)
18098         else
18099           havebond=.false.
18100           ljm=-0.25D0*ljB*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)
18101           d_ljm(1)=-0.5D0*bb_aq(itypi,itypj)/aa_aq(itypi,itypj)*ljB
18102           d_ljm(2)=d_ljm(1)*(0.5D0*eps2rt_om2/eps2rt+alf2/eps3rt)
18103           d_ljm(3)=d_ljm(1)*(0.5D0*eps1_om12+0.5D0*eps2rt_om12/eps2rt- &
18104                alf12/eps3rt)
18105           d_ljm(1)=d_ljm(1)*(0.5D0*eps2rt_om1/eps2rt-alf1/eps3rt)
18106           f1=(rij-ljxm)/(xm-ljxm)
18107           f2=(rij-xm)/(ljxm-xm)
18108           h1=h_base(f1,hd1)
18109           h2=h_base(f2,hd2)
18110           eij=Ht*h1+ljm*h2
18111           delta_inv=1.0d0/(ljxm-xm)
18112           deltasq_inv=delta_inv*delta_inv
18113           fac=Ht*hd1-ljm*hd2
18114           fac1=deltasq_inv*fac*(ljxm-rij)
18115           fac2=deltasq_inv*fac*(rij-xm)
18116           ed=delta_inv*(ljm*hd2-Ht*hd1)
18117           eom1=fac1*d_xm(1)+fac2*d_ljxm(1)+h2*d_ljm(1)
18118           eom2=fac1*d_xm(2)+fac2*d_ljxm(2)+h2*d_ljm(2)
18119           eom12=fac1*d_xm(3)+fac2*d_ljxm(3)+h2*d_ljm(3)
18120         endif
18121 !-------END FIRST METHOD, DISCONTINUOUS SECOND DERIVATIVE
18122
18123 !-------SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18124 !$$$        ssd=rij-ssXs
18125 !$$$        ljd=rij-ljXs
18126 !$$$        fac1=rij-ljxm
18127 !$$$        fac2=rij-ssxm
18128 !$$$
18129 !$$$        d_ljB(1)=ljB*(eps2rt_om1/eps2rt-2.0d0*alf1/eps3rt)
18130 !$$$        d_ljB(2)=ljB*(eps2rt_om2/eps2rt+2.0d0*alf2/eps3rt)
18131 !$$$        d_ljB(3)=ljB*(eps1_om12+eps2rt_om12/eps2rt-2.0d0*alf12/eps3rt)
18132 !$$$
18133 !$$$        ssm=ssC-0.25D0*ssB*ssB/ssA
18134 !$$$        d_ssm(1)=0.5D0*akct*ssB/ssA
18135 !$$$        d_ssm(2)=2.0D0*akth*deltat2-om1*omega-d_ssm(1)
18136 !$$$        d_ssm(1)=-2.0D0*akth*deltat1-om2*omega+d_ssm(1)
18137 !$$$        d_ssm(3)=omega
18138 !$$$
18139 !$$$        ljm=-0.25D0*bb(itypi,itypj)/aa(itypi,itypj)
18140 !$$$        do k=1,3
18141 !$$$          d_ljm(k)=ljm*d_ljB(k)
18142 !$$$        enddo
18143 !$$$        ljm=ljm*ljB
18144 !$$$
18145 !$$$        ss=ssA*ssd*ssd+ssB*ssd+ssC
18146 !$$$        d_ss(0)=2.0d0*ssA*ssd+ssB
18147 !$$$        d_ss(2)=akct*ssd
18148 !$$$        d_ss(1)=-d_ss(2)-2.0d0*akth*deltat1-om2*omega
18149 !$$$        d_ss(2)=d_ss(2)+2.0d0*akth*deltat2-om1*omega
18150 !$$$        d_ss(3)=omega
18151 !$$$
18152 !$$$        ljf=bb(itypi,itypj)/aa(itypi,itypj)
18153 !$$$        ljf=9.0d0*ljf*(-0.5d0*ljf)**(1.0d0/3.0d0)
18154 !$$$        d_ljf(0)=ljf*2.0d0*ljB*fac1
18155 !$$$        do k=1,3
18156 !$$$          d_ljf(k)=d_ljm(k)+ljf*(d_ljB(k)*fac1*fac1-
18157 !$$$     &         2.0d0*ljB*fac1*d_ljxm(k))
18158 !$$$        enddo
18159 !$$$        ljf=ljm+ljf*ljB*fac1*fac1
18160 !$$$
18161 !$$$        f1=(rij-ljxm)/(ssxm-ljxm)
18162 !$$$        f2=(rij-ssxm)/(ljxm-ssxm)
18163 !$$$        h1=h_base(f1,hd1)
18164 !$$$        h2=h_base(f2,hd2)
18165 !$$$        eij=ss*h1+ljf*h2
18166 !$$$        delta_inv=1.0d0/(ljxm-ssxm)
18167 !$$$        deltasq_inv=delta_inv*delta_inv
18168 !$$$        fac=ljf*hd2-ss*hd1
18169 !$$$        ed=d_ss(0)*h1+d_ljf(0)*h2+delta_inv*fac
18170 !$$$        eom1=d_ss(1)*h1+d_ljf(1)*h2+deltasq_inv*fac*
18171 !$$$     &       (fac1*d_ssxm(1)-fac2*(d_ljxm(1)))
18172 !$$$        eom2=d_ss(2)*h1+d_ljf(2)*h2+deltasq_inv*fac*
18173 !$$$     &       (fac1*d_ssxm(2)-fac2*(d_ljxm(2)))
18174 !$$$        eom12=d_ss(3)*h1+d_ljf(3)*h2+deltasq_inv*fac*
18175 !$$$     &       (fac1*d_ssxm(3)-fac2*(d_ljxm(3)))
18176 !$$$
18177 !$$$        havebond=.false.
18178 !$$$        if (ed.gt.0.0d0) havebond=.true.
18179 !-------END SECOND METHOD, CONTINUOUS SECOND DERIVATIVE
18180
18181       endif
18182
18183       if (havebond) then
18184 !#ifndef CLUST
18185 !#ifndef WHAM
18186 !        if (dyn_ssbond_ij(i,j).eq.1.0d300) then
18187 !          write(iout,'(a15,f12.2,f8.1,2i5)')
18188 !     &         "SSBOND_E_FORM",totT,t_bath,i,j
18189 !        endif
18190 !#endif
18191 !#endif
18192         dyn_ssbond_ij(i,j)=eij
18193       else if (.not.havebond .and. dyn_ssbond_ij(i,j).lt.1.0d300) then
18194         dyn_ssbond_ij(i,j)=1.0d300
18195 !#ifndef CLUST
18196 !#ifndef WHAM
18197 !        write(iout,'(a15,f12.2,f8.1,2i5)')
18198 !     &       "SSBOND_E_BREAK",totT,t_bath,i,j
18199 !#endif
18200 !#endif
18201       endif
18202
18203 !-------TESTING CODE
18204 !el      if (checkstop) then
18205         if (jcheck.eq.0) write(iout,'(a,3f15.8,$)') &
18206              "CHECKSTOP",rij,eij,ed
18207         echeck(jcheck)=eij
18208 !el      endif
18209       enddo
18210       if (checkstop) then
18211         write(iout,'(f15.8)')(echeck(1)-echeck(-1))*0.5d0/deps
18212       endif
18213       enddo
18214       if (checkstop) then
18215         transgrad=.true.
18216         checkstop=.false.
18217       endif
18218 !-------END TESTING CODE
18219
18220       do k=1,3
18221         dcosom1(k)=(dc_norm(k,nres+i)-om1*erij(k))/rij
18222         dcosom2(k)=(dc_norm(k,nres+j)-om2*erij(k))/rij
18223       enddo
18224       do k=1,3
18225         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
18226       enddo
18227       do k=1,3
18228         gvdwx(k,i)=gvdwx(k,i)-gg(k) &
18229              +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
18230              +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
18231         gvdwx(k,j)=gvdwx(k,j)+gg(k) &
18232              +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
18233              +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
18234       enddo
18235 !grad      do k=i,j-1
18236 !grad        do l=1,3
18237 !grad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
18238 !grad        enddo
18239 !grad      enddo
18240
18241       do l=1,3
18242         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18243         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18244       enddo
18245
18246       return
18247       end subroutine dyn_ssbond_ene
18248 !--------------------------------------------------------------------------
18249          subroutine triple_ssbond_ene(resi,resj,resk,eij)
18250 !      implicit none
18251 !      Includes
18252       use calc_data
18253       use comm_sschecks
18254 !      include 'DIMENSIONS'
18255 !      include 'COMMON.SBRIDGE'
18256 !      include 'COMMON.CHAIN'
18257 !      include 'COMMON.DERIV'
18258 !      include 'COMMON.LOCAL'
18259 !      include 'COMMON.INTERACT'
18260 !      include 'COMMON.VAR'
18261 !      include 'COMMON.IOUNITS'
18262 !      include 'COMMON.CALC'
18263 #ifndef CLUST
18264 #ifndef WHAM
18265        use MD_data
18266 !      include 'COMMON.MD'
18267 !      use MD, only: totT,t_bath
18268 #endif
18269 #endif
18270       double precision h_base
18271       external h_base
18272
18273 !c     Input arguments
18274       integer resi,resj,resk,m,itypi,itypj,itypk
18275
18276 !c     Output arguments
18277       double precision eij,eij1,eij2,eij3
18278
18279 !c     Local variables
18280       logical havebond
18281 !c      integer itypi,itypj,k,l
18282       double precision rrij,ssd,deltat1,deltat2,deltat12,cosphi
18283       double precision rrik,rrjk,rik,rjk,xi,xk,yi,yk,zi,zk,xij,yij,zij
18284       double precision xik,yik,zik,xjk,yjk,zjk,dxk,dyk,dzk
18285       double precision sig0ij,ljd,sig,fac,e1,e2
18286       double precision dcosom1(3),dcosom2(3),ed
18287       double precision pom1,pom2
18288       double precision ljA,ljB,ljXs
18289       double precision d_ljB(1:3)
18290       double precision ssA,ssB,ssC,ssXs
18291       double precision ssxm,ljxm,ssm,ljm
18292       double precision d_ssxm(1:3),d_ljxm(1:3),d_ssm(1:3),d_ljm(1:3)
18293       eij=0.0
18294       if (dtriss.eq.0) return
18295       i=resi
18296       j=resj
18297       k=resk
18298 !C      write(iout,*) resi,resj,resk
18299       itypi=itype(i,1)
18300       dxi=dc_norm(1,nres+i)
18301       dyi=dc_norm(2,nres+i)
18302       dzi=dc_norm(3,nres+i)
18303       dsci_inv=vbld_inv(i+nres)
18304       xi=c(1,nres+i)
18305       yi=c(2,nres+i)
18306       zi=c(3,nres+i)
18307       itypj=itype(j,1)
18308       xj=c(1,nres+j)
18309       yj=c(2,nres+j)
18310       zj=c(3,nres+j)
18311
18312       dxj=dc_norm(1,nres+j)
18313       dyj=dc_norm(2,nres+j)
18314       dzj=dc_norm(3,nres+j)
18315       dscj_inv=vbld_inv(j+nres)
18316       itypk=itype(k,1)
18317       xk=c(1,nres+k)
18318       yk=c(2,nres+k)
18319       zk=c(3,nres+k)
18320
18321       dxk=dc_norm(1,nres+k)
18322       dyk=dc_norm(2,nres+k)
18323       dzk=dc_norm(3,nres+k)
18324       dscj_inv=vbld_inv(k+nres)
18325       xij=xj-xi
18326       xik=xk-xi
18327       xjk=xk-xj
18328       yij=yj-yi
18329       yik=yk-yi
18330       yjk=yk-yj
18331       zij=zj-zi
18332       zik=zk-zi
18333       zjk=zk-zj
18334       rrij=(xij*xij+yij*yij+zij*zij)
18335       rij=dsqrt(rrij)  ! sc_angular needs rij to really be the inverse
18336       rrik=(xik*xik+yik*yik+zik*zik)
18337       rik=dsqrt(rrik)
18338       rrjk=(xjk*xjk+yjk*yjk+zjk*zjk)
18339       rjk=dsqrt(rrjk)
18340 !C there are three combination of distances for each trisulfide bonds
18341 !C The first case the ith atom is the center
18342 !C Energy function is E=d/(a*(x-y)**2+b*(x+y)**2+c) where x is first
18343 !C distance y is second distance the a,b,c,d are parameters derived for
18344 !C this problem d parameter was set as a penalty currenlty set to 1.
18345       if ((iabs(j-i).le.2).or.(iabs(i-k).le.2)) then
18346       eij1=0.0d0
18347       else
18348       eij1=dtriss/(atriss*(rij-rik)**2+btriss*(rij+rik)**6+ctriss)
18349       endif
18350 !C second case jth atom is center
18351       if ((iabs(j-i).le.2).or.(iabs(j-k).le.2)) then
18352       eij2=0.0d0
18353       else
18354       eij2=dtriss/(atriss*(rij-rjk)**2+btriss*(rij+rjk)**6+ctriss)
18355       endif
18356 !C the third case kth atom is the center
18357       if ((iabs(i-k).le.2).or.(iabs(j-k).le.2)) then
18358       eij3=0.0d0
18359       else
18360       eij3=dtriss/(atriss*(rik-rjk)**2+btriss*(rik+rjk)**6+ctriss)
18361       endif
18362 !C      eij2=0.0
18363 !C      eij3=0.0
18364 !C      eij1=0.0
18365       eij=eij1+eij2+eij3
18366 !C      write(iout,*)i,j,k,eij
18367 !C The energy penalty calculated now time for the gradient part
18368 !C derivative over rij
18369       fac=-eij1**2/dtriss*(2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18370       -eij2**2/dtriss*(2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)
18371             gg(1)=xij*fac/rij
18372             gg(2)=yij*fac/rij
18373             gg(3)=zij*fac/rij
18374       do m=1,3
18375         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18376         gvdwx(m,j)=gvdwx(m,j)+gg(m)
18377       enddo
18378
18379       do l=1,3
18380         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18381         gvdwc(l,j)=gvdwc(l,j)+gg(l)
18382       enddo
18383 !C now derivative over rik
18384       fac=-eij1**2/dtriss* &
18385       (-2.0*atriss*(rij-rik)+6.0*btriss*(rij+rik)**5) &
18386       -eij3**2/dtriss*(2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18387             gg(1)=xik*fac/rik
18388             gg(2)=yik*fac/rik
18389             gg(3)=zik*fac/rik
18390       do m=1,3
18391         gvdwx(m,i)=gvdwx(m,i)-gg(m)
18392         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18393       enddo
18394       do l=1,3
18395         gvdwc(l,i)=gvdwc(l,i)-gg(l)
18396         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18397       enddo
18398 !C now derivative over rjk
18399       fac=-eij2**2/dtriss* &
18400       (-2.0*atriss*(rij-rjk)+6.0*btriss*(rij+rjk)**5)- &
18401       eij3**2/dtriss*(-2.0*atriss*(rik-rjk)+6.0*btriss*(rik+rjk)**5)
18402             gg(1)=xjk*fac/rjk
18403             gg(2)=yjk*fac/rjk
18404             gg(3)=zjk*fac/rjk
18405       do m=1,3
18406         gvdwx(m,j)=gvdwx(m,j)-gg(m)
18407         gvdwx(m,k)=gvdwx(m,k)+gg(m)
18408       enddo
18409       do l=1,3
18410         gvdwc(l,j)=gvdwc(l,j)-gg(l)
18411         gvdwc(l,k)=gvdwc(l,k)+gg(l)
18412       enddo
18413       return
18414       end subroutine triple_ssbond_ene
18415
18416
18417
18418 !-----------------------------------------------------------------------------
18419       real(kind=8) function h_base(x,deriv)
18420 !     A smooth function going 0->1 in range [0,1]
18421 !     It should NOT be called outside range [0,1], it will not work there.
18422       implicit none
18423
18424 !     Input arguments
18425       real(kind=8) :: x
18426
18427 !     Output arguments
18428       real(kind=8) :: deriv
18429
18430 !     Local variables
18431       real(kind=8) :: xsq
18432
18433
18434 !     Two parabolas put together.  First derivative zero at extrema
18435 !$$$      if (x.lt.0.5D0) then
18436 !$$$        h_base=2.0D0*x*x
18437 !$$$        deriv=4.0D0*x
18438 !$$$      else
18439 !$$$        deriv=1.0D0-x
18440 !$$$        h_base=1.0D0-2.0D0*deriv*deriv
18441 !$$$        deriv=4.0D0*deriv
18442 !$$$      endif
18443
18444 !     Third degree polynomial.  First derivative zero at extrema
18445       h_base=x*x*(3.0d0-2.0d0*x)
18446       deriv=6.0d0*x*(1.0d0-x)
18447
18448 !     Fifth degree polynomial.  First and second derivatives zero at extrema
18449 !$$$      xsq=x*x
18450 !$$$      h_base=x*xsq*(6.0d0*xsq-15.0d0*x+10.0d0)
18451 !$$$      deriv=x-1.0d0
18452 !$$$      deriv=deriv*deriv
18453 !$$$      deriv=30.0d0*xsq*deriv
18454
18455       return
18456       end function h_base
18457 !-----------------------------------------------------------------------------
18458       subroutine dyn_set_nss
18459 !     Adjust nss and other relevant variables based on dyn_ssbond_ij
18460 !      implicit none
18461       use MD_data, only: totT,t_bath
18462 !     Includes
18463 !      include 'DIMENSIONS'
18464 #ifdef MPI
18465       include "mpif.h"
18466 #endif
18467 !      include 'COMMON.SBRIDGE'
18468 !      include 'COMMON.CHAIN'
18469 !      include 'COMMON.IOUNITS'
18470 !      include 'COMMON.SETUP'
18471 !      include 'COMMON.MD'
18472 !     Local variables
18473       real(kind=8) :: emin
18474       integer :: i,j,imin,ierr
18475       integer :: diff,allnss,newnss
18476       integer,dimension(maxdim) :: allflag,allihpb,alljhpb,& !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18477                 newihpb,newjhpb
18478       logical :: found
18479       integer,dimension(0:nfgtasks) :: i_newnss
18480       integer,dimension(0:nfgtasks) :: displ
18481       integer,dimension(maxdim) :: g_newihpb,g_newjhpb !(maxdim)(maxdim=(maxres-1)*(maxres-2)/2)
18482       integer :: g_newnss
18483
18484       allnss=0
18485       do i=1,nres-1
18486         do j=i+1,nres
18487           if (dyn_ssbond_ij(i,j).lt.1.0d300) then
18488             allnss=allnss+1
18489             allflag(allnss)=0
18490             allihpb(allnss)=i
18491             alljhpb(allnss)=j
18492           endif
18493         enddo
18494       enddo
18495
18496 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18497
18498  1    emin=1.0d300
18499       do i=1,allnss
18500         if (allflag(i).eq.0 .and. &
18501              dyn_ssbond_ij(allihpb(i),alljhpb(i)).lt.emin) then
18502           emin=dyn_ssbond_ij(allihpb(i),alljhpb(i))
18503           imin=i
18504         endif
18505       enddo
18506       if (emin.lt.1.0d300) then
18507         allflag(imin)=1
18508         do i=1,allnss
18509           if (allflag(i).eq.0 .and. &
18510                (allihpb(i).eq.allihpb(imin) .or. &
18511                alljhpb(i).eq.allihpb(imin) .or. &
18512                allihpb(i).eq.alljhpb(imin) .or. &
18513                alljhpb(i).eq.alljhpb(imin))) then
18514             allflag(i)=-1
18515           endif
18516         enddo
18517         goto 1
18518       endif
18519
18520 !mc      write(iout,*)"ALLNSS ",allnss,(allihpb(i),alljhpb(i),i=1,allnss)
18521
18522       newnss=0
18523       do i=1,allnss
18524         if (allflag(i).eq.1) then
18525           newnss=newnss+1
18526           newihpb(newnss)=allihpb(i)
18527           newjhpb(newnss)=alljhpb(i)
18528         endif
18529       enddo
18530
18531 #ifdef MPI
18532       if (nfgtasks.gt.1)then
18533
18534         call MPI_Reduce(newnss,g_newnss,1,&
18535           MPI_INTEGER,MPI_SUM,king,FG_COMM,IERR)
18536         call MPI_Gather(newnss,1,MPI_INTEGER,&
18537                         i_newnss,1,MPI_INTEGER,king,FG_COMM,IERR)
18538         displ(0)=0
18539         do i=1,nfgtasks-1,1
18540           displ(i)=i_newnss(i-1)+displ(i-1)
18541         enddo
18542         call MPI_Gatherv(newihpb,newnss,MPI_INTEGER,&
18543                          g_newihpb,i_newnss,displ,MPI_INTEGER,&
18544                          king,FG_COMM,IERR)
18545         call MPI_Gatherv(newjhpb,newnss,MPI_INTEGER,&
18546                          g_newjhpb,i_newnss,displ,MPI_INTEGER,&
18547                          king,FG_COMM,IERR)
18548         if(fg_rank.eq.0) then
18549 !         print *,'g_newnss',g_newnss
18550 !         print *,'g_newihpb',(g_newihpb(i),i=1,g_newnss)
18551 !         print *,'g_newjhpb',(g_newjhpb(i),i=1,g_newnss)
18552          newnss=g_newnss
18553          do i=1,newnss
18554           newihpb(i)=g_newihpb(i)
18555           newjhpb(i)=g_newjhpb(i)
18556          enddo
18557         endif
18558       endif
18559 #endif
18560
18561       diff=newnss-nss
18562
18563 !mc      write(iout,*)"NEWNSS ",newnss,(newihpb(i),newjhpb(i),i=1,newnss)
18564 !       print *,newnss,nss,maxdim
18565       do i=1,nss
18566         found=.false.
18567 !        print *,newnss
18568         do j=1,newnss
18569 !!          print *,j
18570           if (idssb(i).eq.newihpb(j) .and. &
18571                jdssb(i).eq.newjhpb(j)) found=.true.
18572         enddo
18573 #ifndef CLUST
18574 #ifndef WHAM
18575 !        write(iout,*) "found",found,i,j
18576         if (.not.found.and.fg_rank.eq.0) &
18577             write(iout,'(a15,f12.2,f8.1,2i5)') &
18578              "SSBOND_BREAK",totT,t_bath,idssb(i),jdssb(i)
18579 #endif
18580 #endif
18581       enddo
18582
18583       do i=1,newnss
18584         found=.false.
18585         do j=1,nss
18586 !          print *,i,j
18587           if (newihpb(i).eq.idssb(j) .and. &
18588                newjhpb(i).eq.jdssb(j)) found=.true.
18589         enddo
18590 #ifndef CLUST
18591 #ifndef WHAM
18592 !        write(iout,*) "found",found,i,j
18593         if (.not.found.and.fg_rank.eq.0) &
18594             write(iout,'(a15,f12.2,f8.1,2i5)') &
18595              "SSBOND_FORM",totT,t_bath,newihpb(i),newjhpb(i)
18596 #endif
18597 #endif
18598       enddo
18599
18600       nss=newnss
18601       do i=1,nss
18602         idssb(i)=newihpb(i)
18603         jdssb(i)=newjhpb(i)
18604       enddo
18605
18606       return
18607       end subroutine dyn_set_nss
18608 ! Lipid transfer energy function
18609       subroutine Eliptransfer(eliptran)
18610 !C this is done by Adasko
18611 !C      print *,"wchodze"
18612 !C structure of box:
18613 !C      water
18614 !C--bordliptop-- buffore starts
18615 !C--bufliptop--- here true lipid starts
18616 !C      lipid
18617 !C--buflipbot--- lipid ends buffore starts
18618 !C--bordlipbot--buffore ends
18619       real(kind=8) :: fracinbuf,eliptran,sslip,positi,ssgradlip
18620       integer :: i
18621       eliptran=0.0
18622 !      print *, "I am in eliptran"
18623       do i=ilip_start,ilip_end
18624 !C       do i=1,1
18625         if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1).or.(i.eq.nres))&
18626          cycle
18627
18628         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
18629         if (positi.le.0.0) positi=positi+boxzsize
18630 !C        print *,i
18631 !C first for peptide groups
18632 !c for each residue check if it is in lipid or lipid water border area
18633        if ((positi.gt.bordlipbot)  &
18634       .and.(positi.lt.bordliptop)) then
18635 !C the energy transfer exist
18636         if (positi.lt.buflipbot) then
18637 !C what fraction I am in
18638          fracinbuf=1.0d0-      &
18639              ((positi-bordlipbot)/lipbufthick)
18640 !C lipbufthick is thickenes of lipid buffore
18641          sslip=sscalelip(fracinbuf)
18642          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18643          eliptran=eliptran+sslip*pepliptran
18644          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18645          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18646 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18647
18648 !C        print *,"doing sccale for lower part"
18649 !C         print *,i,sslip,fracinbuf,ssgradlip
18650         elseif (positi.gt.bufliptop) then
18651          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
18652          sslip=sscalelip(fracinbuf)
18653          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18654          eliptran=eliptran+sslip*pepliptran
18655          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
18656          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
18657 !C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
18658 !C          print *, "doing sscalefor top part"
18659 !C         print *,i,sslip,fracinbuf,ssgradlip
18660         else
18661          eliptran=eliptran+pepliptran
18662 !C         print *,"I am in true lipid"
18663         endif
18664 !C       else
18665 !C       eliptran=elpitran+0.0 ! I am in water
18666        endif
18667        if (energy_dec) write(iout,*) i,"eliptran=",eliptran,positi,sslip
18668        enddo
18669 ! here starts the side chain transfer
18670        do i=ilip_start,ilip_end
18671         if (itype(i,1).eq.ntyp1) cycle
18672         positi=(mod(c(3,i+nres),boxzsize))
18673         if (positi.le.0) positi=positi+boxzsize
18674 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18675 !c for each residue check if it is in lipid or lipid water border area
18676 !C       respos=mod(c(3,i+nres),boxzsize)
18677 !C       print *,positi,bordlipbot,buflipbot
18678        if ((positi.gt.bordlipbot) &
18679        .and.(positi.lt.bordliptop)) then
18680 !C the energy transfer exist
18681         if (positi.lt.buflipbot) then
18682          fracinbuf=1.0d0-   &
18683            ((positi-bordlipbot)/lipbufthick)
18684 !C lipbufthick is thickenes of lipid buffore
18685          sslip=sscalelip(fracinbuf)
18686          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
18687          eliptran=eliptran+sslip*liptranene(itype(i,1))
18688          gliptranx(3,i)=gliptranx(3,i) &
18689       +ssgradlip*liptranene(itype(i,1))
18690          gliptranc(3,i-1)= gliptranc(3,i-1) &
18691       +ssgradlip*liptranene(itype(i,1))
18692 !C         print *,"doing sccale for lower part"
18693         elseif (positi.gt.bufliptop) then
18694          fracinbuf=1.0d0-  &
18695       ((bordliptop-positi)/lipbufthick)
18696          sslip=sscalelip(fracinbuf)
18697          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
18698          eliptran=eliptran+sslip*liptranene(itype(i,1))
18699          gliptranx(3,i)=gliptranx(3,i)  &
18700        +ssgradlip*liptranene(itype(i,1))
18701          gliptranc(3,i-1)= gliptranc(3,i-1) &
18702       +ssgradlip*liptranene(itype(i,1))
18703 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18704         else
18705          eliptran=eliptran+liptranene(itype(i,1))
18706 !C         print *,"I am in true lipid"
18707         endif
18708         endif ! if in lipid or buffor
18709 !C       else
18710 !C       eliptran=elpitran+0.0 ! I am in water
18711         if (energy_dec) write(iout,*) i,"eliptran=",eliptran
18712        enddo
18713        return
18714        end  subroutine Eliptransfer
18715 !----------------------------------NANO FUNCTIONS
18716 !C-----------------------------------------------------------------------
18717 !C-----------------------------------------------------------
18718 !C This subroutine is to mimic the histone like structure but as well can be
18719 !C utilizet to nanostructures (infinit) small modification has to be used to
18720 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18721 !C gradient has to be modified at the ends
18722 !C The energy function is Kihara potential
18723 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18724 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18725 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18726 !C simple Kihara potential
18727       subroutine calctube(Etube)
18728       real(kind=8),dimension(3) :: vectube
18729       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18730        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi, &
18731        sc_aa_tube,sc_bb_tube
18732       integer :: i,j,iti
18733       Etube=0.0d0
18734       do i=itube_start,itube_end
18735         enetube(i)=0.0d0
18736         enetube(i+nres)=0.0d0
18737       enddo
18738 !C first we calculate the distance from tube center
18739 !C for UNRES
18740        do i=itube_start,itube_end
18741 !C lets ommit dummy atoms for now
18742        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18743 !C now calculate distance from center of tube and direction vectors
18744       xmin=boxxsize
18745       ymin=boxysize
18746 ! Find minimum distance in periodic box
18747         do j=-1,1
18748          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18749          vectube(1)=vectube(1)+boxxsize*j
18750          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18751          vectube(2)=vectube(2)+boxysize*j
18752          xminact=abs(vectube(1)-tubecenter(1))
18753          yminact=abs(vectube(2)-tubecenter(2))
18754            if (xmin.gt.xminact) then
18755             xmin=xminact
18756             xtemp=vectube(1)
18757            endif
18758            if (ymin.gt.yminact) then
18759              ymin=yminact
18760              ytemp=vectube(2)
18761             endif
18762          enddo
18763       vectube(1)=xtemp
18764       vectube(2)=ytemp
18765       vectube(1)=vectube(1)-tubecenter(1)
18766       vectube(2)=vectube(2)-tubecenter(2)
18767
18768 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18769 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18770
18771 !C as the tube is infinity we do not calculate the Z-vector use of Z
18772 !C as chosen axis
18773       vectube(3)=0.0d0
18774 !C now calculte the distance
18775        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18776 !C now normalize vector
18777       vectube(1)=vectube(1)/tub_r
18778       vectube(2)=vectube(2)/tub_r
18779 !C calculte rdiffrence between r and r0
18780       rdiff=tub_r-tubeR0
18781 !C and its 6 power
18782       rdiff6=rdiff**6.0d0
18783 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18784        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
18785 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
18786 !C       print *,rdiff,rdiff6,pep_aa_tube
18787 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
18788 !C now we calculate gradient
18789        fac=(-12.0d0*pep_aa_tube/rdiff6- &
18790             6.0d0*pep_bb_tube)/rdiff6/rdiff
18791 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
18792 !C     &rdiff,fac
18793 !C now direction of gg_tube vector
18794         do j=1,3
18795         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
18796         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
18797         enddo
18798         enddo
18799 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
18800 !C        print *,gg_tube(1,0),"TU"
18801
18802
18803        do i=itube_start,itube_end
18804 !C Lets not jump over memory as we use many times iti
18805          iti=itype(i,1)
18806 !C lets ommit dummy atoms for now
18807          if ((iti.eq.ntyp1)  &
18808 !C in UNRES uncomment the line below as GLY has no side-chain...
18809 !C      .or.(iti.eq.10)
18810         ) cycle
18811       xmin=boxxsize
18812       ymin=boxysize
18813         do j=-1,1
18814          vectube(1)=mod((c(1,i+nres)),boxxsize)
18815          vectube(1)=vectube(1)+boxxsize*j
18816          vectube(2)=mod((c(2,i+nres)),boxysize)
18817          vectube(2)=vectube(2)+boxysize*j
18818
18819          xminact=abs(vectube(1)-tubecenter(1))
18820          yminact=abs(vectube(2)-tubecenter(2))
18821            if (xmin.gt.xminact) then
18822             xmin=xminact
18823             xtemp=vectube(1)
18824            endif
18825            if (ymin.gt.yminact) then
18826              ymin=yminact
18827              ytemp=vectube(2)
18828             endif
18829          enddo
18830       vectube(1)=xtemp
18831       vectube(2)=ytemp
18832 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
18833 !C     &     tubecenter(2)
18834       vectube(1)=vectube(1)-tubecenter(1)
18835       vectube(2)=vectube(2)-tubecenter(2)
18836
18837 !C as the tube is infinity we do not calculate the Z-vector use of Z
18838 !C as chosen axis
18839       vectube(3)=0.0d0
18840 !C now calculte the distance
18841        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18842 !C now normalize vector
18843       vectube(1)=vectube(1)/tub_r
18844       vectube(2)=vectube(2)/tub_r
18845
18846 !C calculte rdiffrence between r and r0
18847       rdiff=tub_r-tubeR0
18848 !C and its 6 power
18849       rdiff6=rdiff**6.0d0
18850 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18851        sc_aa_tube=sc_aa_tube_par(iti)
18852        sc_bb_tube=sc_bb_tube_par(iti)
18853        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
18854        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-  &
18855              6.0d0*sc_bb_tube/rdiff6/rdiff
18856 !C now direction of gg_tube vector
18857          do j=1,3
18858           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
18859           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
18860          enddo
18861         enddo
18862         do i=itube_start,itube_end
18863           Etube=Etube+enetube(i)+enetube(i+nres)
18864         enddo
18865 !C        print *,"ETUBE", etube
18866         return
18867         end subroutine calctube
18868 !C TO DO 1) add to total energy
18869 !C       2) add to gradient summation
18870 !C       3) add reading parameters (AND of course oppening of PARAM file)
18871 !C       4) add reading the center of tube
18872 !C       5) add COMMONs
18873 !C       6) add to zerograd
18874 !C       7) allocate matrices
18875
18876
18877 !C-----------------------------------------------------------------------
18878 !C-----------------------------------------------------------
18879 !C This subroutine is to mimic the histone like structure but as well can be
18880 !C utilizet to nanostructures (infinit) small modification has to be used to
18881 !C make it finite (z gradient at the ends has to be changes as well as the x,y
18882 !C gradient has to be modified at the ends
18883 !C The energy function is Kihara potential
18884 !C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
18885 !C 4eps is depth of well sigma is r_minimum r is distance from center of tube
18886 !C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
18887 !C simple Kihara potential
18888       subroutine calctube2(Etube)
18889             real(kind=8),dimension(3) :: vectube
18890       real(kind=8) :: Etube,xtemp,xminact,yminact,&
18891        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,positi,fracinbuf,&
18892        sstube,ssgradtube,sc_aa_tube,sc_bb_tube
18893       integer:: i,j,iti
18894       Etube=0.0d0
18895       do i=itube_start,itube_end
18896         enetube(i)=0.0d0
18897         enetube(i+nres)=0.0d0
18898       enddo
18899 !C first we calculate the distance from tube center
18900 !C first sugare-phosphate group for NARES this would be peptide group
18901 !C for UNRES
18902        do i=itube_start,itube_end
18903 !C lets ommit dummy atoms for now
18904
18905        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
18906 !C now calculate distance from center of tube and direction vectors
18907 !C      vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18908 !C          if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
18909 !C      vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18910 !C          if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
18911       xmin=boxxsize
18912       ymin=boxysize
18913         do j=-1,1
18914          vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
18915          vectube(1)=vectube(1)+boxxsize*j
18916          vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
18917          vectube(2)=vectube(2)+boxysize*j
18918
18919          xminact=abs(vectube(1)-tubecenter(1))
18920          yminact=abs(vectube(2)-tubecenter(2))
18921            if (xmin.gt.xminact) then
18922             xmin=xminact
18923             xtemp=vectube(1)
18924            endif
18925            if (ymin.gt.yminact) then
18926              ymin=yminact
18927              ytemp=vectube(2)
18928             endif
18929          enddo
18930       vectube(1)=xtemp
18931       vectube(2)=ytemp
18932       vectube(1)=vectube(1)-tubecenter(1)
18933       vectube(2)=vectube(2)-tubecenter(2)
18934
18935 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
18936 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
18937
18938 !C as the tube is infinity we do not calculate the Z-vector use of Z
18939 !C as chosen axis
18940       vectube(3)=0.0d0
18941 !C now calculte the distance
18942        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
18943 !C now normalize vector
18944       vectube(1)=vectube(1)/tub_r
18945       vectube(2)=vectube(2)/tub_r
18946 !C calculte rdiffrence between r and r0
18947       rdiff=tub_r-tubeR0
18948 !C and its 6 power
18949       rdiff6=rdiff**6.0d0
18950 !C THIS FRAGMENT MAKES TUBE FINITE
18951         positi=mod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
18952         if (positi.le.0) positi=positi+boxzsize
18953 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
18954 !c for each residue check if it is in lipid or lipid water border area
18955 !C       respos=mod(c(3,i+nres),boxzsize)
18956 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
18957        if ((positi.gt.bordtubebot)  &
18958         .and.(positi.lt.bordtubetop)) then
18959 !C the energy transfer exist
18960         if (positi.lt.buftubebot) then
18961          fracinbuf=1.0d0-  &
18962            ((positi-bordtubebot)/tubebufthick)
18963 !C lipbufthick is thickenes of lipid buffore
18964          sstube=sscalelip(fracinbuf)
18965          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
18966 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
18967          enetube(i)=enetube(i)+sstube*tubetranenepep
18968 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18969 !C     &+ssgradtube*tubetranene(itype(i,1))
18970 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18971 !C     &+ssgradtube*tubetranene(itype(i,1))
18972 !C         print *,"doing sccale for lower part"
18973         elseif (positi.gt.buftubetop) then
18974          fracinbuf=1.0d0-  &
18975         ((bordtubetop-positi)/tubebufthick)
18976          sstube=sscalelip(fracinbuf)
18977          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
18978          enetube(i)=enetube(i)+sstube*tubetranenepep
18979 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
18980 !C     &+ssgradtube*tubetranene(itype(i,1))
18981 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
18982 !C     &+ssgradtube*tubetranene(itype(i,1))
18983 !C          print *, "doing sscalefor top part",sslip,fracinbuf
18984         else
18985          sstube=1.0d0
18986          ssgradtube=0.0d0
18987          enetube(i)=enetube(i)+sstube*tubetranenepep
18988 !C         print *,"I am in true lipid"
18989         endif
18990         else
18991 !C          sstube=0.0d0
18992 !C          ssgradtube=0.0d0
18993         cycle
18994         endif ! if in lipid or buffor
18995
18996 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
18997        enetube(i)=enetube(i)+sstube* &
18998         (pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6)
18999 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19000 !C       print *,rdiff,rdiff6,pep_aa_tube
19001 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19002 !C now we calculate gradient
19003        fac=(-12.0d0*pep_aa_tube/rdiff6-  &
19004              6.0d0*pep_bb_tube)/rdiff6/rdiff*sstube
19005 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19006 !C     &rdiff,fac
19007
19008 !C now direction of gg_tube vector
19009        do j=1,3
19010         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19011         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19012         enddo
19013          gg_tube(3,i)=gg_tube(3,i)  &
19014        +ssgradtube*enetube(i)/sstube/2.0d0
19015          gg_tube(3,i-1)= gg_tube(3,i-1)  &
19016        +ssgradtube*enetube(i)/sstube/2.0d0
19017
19018         enddo
19019 !C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
19020 !C        print *,gg_tube(1,0),"TU"
19021         do i=itube_start,itube_end
19022 !C Lets not jump over memory as we use many times iti
19023          iti=itype(i,1)
19024 !C lets ommit dummy atoms for now
19025          if ((iti.eq.ntyp1) &
19026 !!C in UNRES uncomment the line below as GLY has no side-chain...
19027            .or.(iti.eq.10) &
19028           ) cycle
19029           vectube(1)=c(1,i+nres)
19030           vectube(1)=mod(vectube(1),boxxsize)
19031           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
19032           vectube(2)=c(2,i+nres)
19033           vectube(2)=mod(vectube(2),boxysize)
19034           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxysize
19035
19036       vectube(1)=vectube(1)-tubecenter(1)
19037       vectube(2)=vectube(2)-tubecenter(2)
19038 !C THIS FRAGMENT MAKES TUBE FINITE
19039         positi=(mod(c(3,i+nres),boxzsize))
19040         if (positi.le.0) positi=positi+boxzsize
19041 !C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
19042 !c for each residue check if it is in lipid or lipid water border area
19043 !C       respos=mod(c(3,i+nres),boxzsize)
19044 !C       print *,positi,bordtubebot,buftubebot,bordtubetop
19045
19046        if ((positi.gt.bordtubebot)  &
19047         .and.(positi.lt.bordtubetop)) then
19048 !C the energy transfer exist
19049         if (positi.lt.buftubebot) then
19050          fracinbuf=1.0d0- &
19051             ((positi-bordtubebot)/tubebufthick)
19052 !C lipbufthick is thickenes of lipid buffore
19053          sstube=sscalelip(fracinbuf)
19054          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
19055 !C         print *,ssgradtube, sstube,tubetranene(itype(i,1))
19056          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19057 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19058 !C     &+ssgradtube*tubetranene(itype(i,1))
19059 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19060 !C     &+ssgradtube*tubetranene(itype(i,1))
19061 !C         print *,"doing sccale for lower part"
19062         elseif (positi.gt.buftubetop) then
19063          fracinbuf=1.0d0- &
19064         ((bordtubetop-positi)/tubebufthick)
19065
19066          sstube=sscalelip(fracinbuf)
19067          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
19068          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19069 !C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
19070 !C     &+ssgradtube*tubetranene(itype(i,1))
19071 !C         gg_tube(3,i-1)= gg_tube(3,i-1)
19072 !C     &+ssgradtube*tubetranene(itype(i,1))
19073 !C          print *, "doing sscalefor top part",sslip,fracinbuf
19074         else
19075          sstube=1.0d0
19076          ssgradtube=0.0d0
19077          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i,1))
19078 !C         print *,"I am in true lipid"
19079         endif
19080         else
19081 !C          sstube=0.0d0
19082 !C          ssgradtube=0.0d0
19083         cycle
19084         endif ! if in lipid or buffor
19085 !CEND OF FINITE FRAGMENT
19086 !C as the tube is infinity we do not calculate the Z-vector use of Z
19087 !C as chosen axis
19088       vectube(3)=0.0d0
19089 !C now calculte the distance
19090        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19091 !C now normalize vector
19092       vectube(1)=vectube(1)/tub_r
19093       vectube(2)=vectube(2)/tub_r
19094 !C calculte rdiffrence between r and r0
19095       rdiff=tub_r-tubeR0
19096 !C and its 6 power
19097       rdiff6=rdiff**6.0d0
19098 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19099        sc_aa_tube=sc_aa_tube_par(iti)
19100        sc_bb_tube=sc_bb_tube_par(iti)
19101        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6)&
19102                        *sstube+enetube(i+nres)
19103 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19104 !C now we calculate gradient
19105        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff-&
19106             6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
19107 !C now direction of gg_tube vector
19108          do j=1,3
19109           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19110           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19111          enddo
19112          gg_tube_SC(3,i)=gg_tube_SC(3,i) &
19113        +ssgradtube*enetube(i+nres)/sstube
19114          gg_tube(3,i-1)= gg_tube(3,i-1) &
19115        +ssgradtube*enetube(i+nres)/sstube
19116
19117         enddo
19118         do i=itube_start,itube_end
19119           Etube=Etube+enetube(i)+enetube(i+nres)
19120         enddo
19121 !C        print *,"ETUBE", etube
19122         return
19123         end subroutine calctube2
19124 !=====================================================================================================================================
19125       subroutine calcnano(Etube)
19126       real(kind=8),dimension(3) :: vectube
19127
19128       real(kind=8) :: Etube,xtemp,xminact,yminact,&
19129        ytemp,xmin,ymin,tub_r,rdiff,rdiff6,fac,denominator,faccav,&
19130        sc_aa_tube,sc_bb_tube,zmin,ztemp,zminact
19131        integer:: i,j,iti,r
19132
19133       Etube=0.0d0
19134 !      print *,itube_start,itube_end,"poczatek"
19135       do i=itube_start,itube_end
19136         enetube(i)=0.0d0
19137         enetube(i+nres)=0.0d0
19138       enddo
19139 !C first we calculate the distance from tube center
19140 !C first sugare-phosphate group for NARES this would be peptide group
19141 !C for UNRES
19142        do i=itube_start,itube_end
19143 !C lets ommit dummy atoms for now
19144        if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle
19145 !C now calculate distance from center of tube and direction vectors
19146       xmin=boxxsize
19147       ymin=boxysize
19148       zmin=boxzsize
19149
19150         do j=-1,1
19151          vectube(1)=dmod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
19152          vectube(1)=vectube(1)+boxxsize*j
19153          vectube(2)=dmod((c(2,i)+c(2,i+1))/2.0d0,boxysize)
19154          vectube(2)=vectube(2)+boxysize*j
19155          vectube(3)=dmod((c(3,i)+c(3,i+1))/2.0d0,boxzsize)
19156          vectube(3)=vectube(3)+boxzsize*j
19157
19158
19159          xminact=dabs(vectube(1)-tubecenter(1))
19160          yminact=dabs(vectube(2)-tubecenter(2))
19161          zminact=dabs(vectube(3)-tubecenter(3))
19162
19163            if (xmin.gt.xminact) then
19164             xmin=xminact
19165             xtemp=vectube(1)
19166            endif
19167            if (ymin.gt.yminact) then
19168              ymin=yminact
19169              ytemp=vectube(2)
19170             endif
19171            if (zmin.gt.zminact) then
19172              zmin=zminact
19173              ztemp=vectube(3)
19174             endif
19175          enddo
19176       vectube(1)=xtemp
19177       vectube(2)=ytemp
19178       vectube(3)=ztemp
19179
19180       vectube(1)=vectube(1)-tubecenter(1)
19181       vectube(2)=vectube(2)-tubecenter(2)
19182       vectube(3)=vectube(3)-tubecenter(3)
19183
19184 !C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
19185 !C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
19186 !C as the tube is infinity we do not calculate the Z-vector use of Z
19187 !C as chosen axis
19188 !C      vectube(3)=0.0d0
19189 !C now calculte the distance
19190        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19191 !C now normalize vector
19192       vectube(1)=vectube(1)/tub_r
19193       vectube(2)=vectube(2)/tub_r
19194       vectube(3)=vectube(3)/tub_r
19195 !C calculte rdiffrence between r and r0
19196       rdiff=tub_r-tubeR0
19197 !C and its 6 power
19198       rdiff6=rdiff**6.0d0
19199 !C for vectorization reasons we will sumup at the end to avoid depenence of previous
19200        enetube(i)=pep_aa_tube/rdiff6**2.0d0+pep_bb_tube/rdiff6
19201 !C       write(iout,*) "TU13",i,rdiff6,enetube(i)
19202 !C       print *,rdiff,rdiff6,pep_aa_tube
19203 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19204 !C now we calculate gradient
19205        fac=(-12.0d0*pep_aa_tube/rdiff6-   &
19206             6.0d0*pep_bb_tube)/rdiff6/rdiff
19207 !C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
19208 !C     &rdiff,fac
19209          if (acavtubpep.eq.0.0d0) then
19210 !C go to 667
19211          enecavtube(i)=0.0
19212          faccav=0.0
19213          else
19214          denominator=(1.0d0+dcavtubpep*rdiff6*rdiff6)
19215          enecavtube(i)=  &
19216         (bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)+ccavtubpep) &
19217         /denominator
19218          enecavtube(i)=0.0
19219          faccav=((bcavtubpep*1.0d0+acavtubpep/2.0d0/dsqrt(rdiff)) &
19220         *denominator-(bcavtubpep*rdiff+acavtubpep*dsqrt(rdiff)   &
19221         +ccavtubpep)*rdiff6**2.0d0/rdiff*dcavtubpep*12.0d0)      &
19222         /denominator**2.0d0
19223 !C         faccav=0.0
19224 !C         fac=fac+faccav
19225 !C 667     continue
19226          endif
19227           if (energy_dec) write(iout,*),i,rdiff,enetube(i),enecavtube(i)
19228         do j=1,3
19229         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
19230         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
19231         enddo
19232         enddo
19233
19234        do i=itube_start,itube_end
19235         enecavtube(i)=0.0d0
19236 !C Lets not jump over memory as we use many times iti
19237          iti=itype(i,1)
19238 !C lets ommit dummy atoms for now
19239          if ((iti.eq.ntyp1) &
19240 !C in UNRES uncomment the line below as GLY has no side-chain...
19241 !C      .or.(iti.eq.10)
19242          ) cycle
19243       xmin=boxxsize
19244       ymin=boxysize
19245       zmin=boxzsize
19246         do j=-1,1
19247          vectube(1)=dmod((c(1,i+nres)),boxxsize)
19248          vectube(1)=vectube(1)+boxxsize*j
19249          vectube(2)=dmod((c(2,i+nres)),boxysize)
19250          vectube(2)=vectube(2)+boxysize*j
19251          vectube(3)=dmod((c(3,i+nres)),boxzsize)
19252          vectube(3)=vectube(3)+boxzsize*j
19253
19254
19255          xminact=dabs(vectube(1)-tubecenter(1))
19256          yminact=dabs(vectube(2)-tubecenter(2))
19257          zminact=dabs(vectube(3)-tubecenter(3))
19258
19259            if (xmin.gt.xminact) then
19260             xmin=xminact
19261             xtemp=vectube(1)
19262            endif
19263            if (ymin.gt.yminact) then
19264              ymin=yminact
19265              ytemp=vectube(2)
19266             endif
19267            if (zmin.gt.zminact) then
19268              zmin=zminact
19269              ztemp=vectube(3)
19270             endif
19271          enddo
19272       vectube(1)=xtemp
19273       vectube(2)=ytemp
19274       vectube(3)=ztemp
19275
19276 !C          write(iout,*), "tututu", vectube(1),tubecenter(1),vectube(2),
19277 !C     &     tubecenter(2)
19278       vectube(1)=vectube(1)-tubecenter(1)
19279       vectube(2)=vectube(2)-tubecenter(2)
19280       vectube(3)=vectube(3)-tubecenter(3)
19281 !C now calculte the distance
19282        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
19283 !C now normalize vector
19284       vectube(1)=vectube(1)/tub_r
19285       vectube(2)=vectube(2)/tub_r
19286       vectube(3)=vectube(3)/tub_r
19287
19288 !C calculte rdiffrence between r and r0
19289       rdiff=tub_r-tubeR0
19290 !C and its 6 power
19291       rdiff6=rdiff**6.0d0
19292        sc_aa_tube=sc_aa_tube_par(iti)
19293        sc_bb_tube=sc_bb_tube_par(iti)
19294        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19295 !C       enetube(i+nres)=0.0d0
19296 !C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
19297 !C now we calculate gradient
19298        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff- &
19299             6.0d0*sc_bb_tube/rdiff6/rdiff
19300 !C       fac=0.0
19301 !C now direction of gg_tube vector
19302 !C Now cavity term E=a(x+bsqrt(x)+c)/(1+dx^12)
19303          if (acavtub(iti).eq.0.0d0) then
19304 !C go to 667
19305          enecavtube(i+nres)=0.0d0
19306          faccav=0.0d0
19307          else
19308          denominator=(1.0d0+dcavtub(iti)*rdiff6*rdiff6)
19309          enecavtube(i+nres)=   &
19310         (bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)+ccavtub(iti)) &
19311         /denominator
19312 !C         enecavtube(i)=0.0
19313          faccav=((bcavtub(iti)*1.0d0+acavtub(iti)/2.0d0/dsqrt(rdiff)) &
19314         *denominator-(bcavtub(iti)*rdiff+acavtub(iti)*dsqrt(rdiff)   &
19315         +ccavtub(iti))*rdiff6**2.0d0/rdiff*dcavtub(iti)*12.0d0)      &
19316         /denominator**2.0d0
19317 !C         faccav=0.0
19318          fac=fac+faccav
19319 !C 667     continue
19320          endif
19321 !C         print *,"TUT",i,iti,rdiff,rdiff6,acavtub(iti),denominator,
19322 !C     &   enecavtube(i),faccav
19323 !C         print *,"licz=",
19324 !C     & (bcavtub(iti)*rdiff+acavtub(iti)*sqrt(rdiff)+ccavtub(iti))
19325 !C         print *,"finene=",enetube(i+nres)+enecavtube(i)
19326          do j=1,3
19327           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
19328           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
19329          enddo
19330           if (energy_dec) write(iout,*),i,rdiff,enetube(i+nres),enecavtube(i+nres)
19331         enddo
19332
19333
19334
19335         do i=itube_start,itube_end
19336           Etube=Etube+enetube(i)+enetube(i+nres)+enecavtube(i) &
19337          +enecavtube(i+nres)
19338         enddo
19339 !        do i=1,20
19340 !         print *,"begin", i,"a"
19341 !         do r=1,10000
19342 !          rdiff=r/100.0d0
19343 !          rdiff6=rdiff**6.0d0
19344 !          sc_aa_tube=sc_aa_tube_par(i)
19345 !          sc_bb_tube=sc_bb_tube_par(i)
19346 !          enetube(i)=sc_aa_tube/rdiff6**2.0d0+sc_bb_tube/rdiff6
19347 !          denominator=(1.0d0+dcavtub(i)*rdiff6*rdiff6)
19348 !          enecavtube(i)=   &
19349 !         (bcavtub(i)*rdiff+acavtub(i)*dsqrt(rdiff)+ccavtub(i)) &
19350 !         /denominator
19351
19352 !          print '(5(f10.3,1x))',rdiff,enetube(i),enecavtube(i),enecavtube(i)+enetube(i)
19353 !         enddo
19354 !         print *,"end",i,"a"
19355 !        enddo
19356 !C        print *,"ETUBE", etube
19357         return
19358         end subroutine calcnano
19359
19360 !===============================================
19361 !--------------------------------------------------------------------------------
19362 !C first for shielding is setting of function of side-chains
19363
19364        subroutine set_shield_fac2
19365        real(kind=8) :: div77_81=0.974996043d0, &
19366         div4_81=0.2222222222d0
19367        real (kind=8) :: dist_pep_side,dist_side_calf,dist_pept_group, &
19368          scale_fac_dist,fac_help_scale,VofOverlap,VolumeTotal,costhet,&
19369          short,long,sinthet,costhet_fac,sh_frac_dist,rkprim,cosphi,   &
19370          sinphi,cosphi_fac,pep_side0pept_group,cosalfa,fac_alfa_sin
19371 !C the vector between center of side_chain and peptide group
19372        real(kind=8),dimension(3) :: pep_side_long,side_calf, &
19373          pept_group,costhet_grad,cosphi_grad_long, &
19374          cosphi_grad_loc,pep_side_norm,side_calf_norm, &
19375          sh_frac_dist_grad,pep_side
19376         integer i,j,k
19377 !C      write(2,*) "ivec",ivec_start,ivec_end
19378       do i=1,nres
19379         fac_shield(i)=0.0d0
19380         do j=1,3
19381         grad_shield(j,i)=0.0d0
19382         enddo
19383       enddo
19384       do i=ivec_start,ivec_end
19385 !C      do i=1,nres-1
19386 !C      if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19387       ishield_list(i)=0
19388       if ((itype(i,1).eq.ntyp1).and.itype(i+1,1).eq.ntyp1) cycle
19389 !Cif there two consequtive dummy atoms there is no peptide group between them
19390 !C the line below has to be changed for FGPROC>1
19391       VolumeTotal=0.0
19392       do k=1,nres
19393        if ((itype(k,1).eq.ntyp1).or.(itype(k,1).eq.10)) cycle
19394        dist_pep_side=0.0
19395        dist_side_calf=0.0
19396        do j=1,3
19397 !C first lets set vector conecting the ithe side-chain with kth side-chain
19398       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
19399 !C      pep_side(j)=2.0d0
19400 !C and vector conecting the side-chain with its proper calfa
19401       side_calf(j)=c(j,k+nres)-c(j,k)
19402 !C      side_calf(j)=2.0d0
19403       pept_group(j)=c(j,i)-c(j,i+1)
19404 !C lets have their lenght
19405       dist_pep_side=pep_side(j)**2+dist_pep_side
19406       dist_side_calf=dist_side_calf+side_calf(j)**2
19407       dist_pept_group=dist_pept_group+pept_group(j)**2
19408       enddo
19409        dist_pep_side=sqrt(dist_pep_side)
19410        dist_pept_group=sqrt(dist_pept_group)
19411        dist_side_calf=sqrt(dist_side_calf)
19412       do j=1,3
19413         pep_side_norm(j)=pep_side(j)/dist_pep_side
19414         side_calf_norm(j)=dist_side_calf
19415       enddo
19416 !C now sscale fraction
19417        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
19418 !       print *,buff_shield,"buff",sh_frac_dist
19419 !C now sscale
19420         if (sh_frac_dist.le.0.0) cycle
19421 !C        print *,ishield_list(i),i
19422 !C If we reach here it means that this side chain reaches the shielding sphere
19423 !C Lets add him to the list for gradient
19424         ishield_list(i)=ishield_list(i)+1
19425 !C ishield_list is a list of non 0 side-chain that contribute to factor gradient
19426 !C this list is essential otherwise problem would be O3
19427         shield_list(ishield_list(i),i)=k
19428 !C Lets have the sscale value
19429         if (sh_frac_dist.gt.1.0) then
19430          scale_fac_dist=1.0d0
19431          do j=1,3
19432          sh_frac_dist_grad(j)=0.0d0
19433          enddo
19434         else
19435          scale_fac_dist=-sh_frac_dist*sh_frac_dist &
19436                         *(2.0d0*sh_frac_dist-3.0d0)
19437          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2) &
19438                        /dist_pep_side/buff_shield*0.5d0
19439          do j=1,3
19440          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
19441 !C         sh_frac_dist_grad(j)=0.0d0
19442 !C         scale_fac_dist=1.0d0
19443 !C         print *,"jestem",scale_fac_dist,fac_help_scale,
19444 !C     &                    sh_frac_dist_grad(j)
19445          enddo
19446         endif
19447 !C this is what is now we have the distance scaling now volume...
19448       short=short_r_sidechain(itype(k,1))
19449       long=long_r_sidechain(itype(k,1))
19450       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
19451       sinthet=short/dist_pep_side*costhet
19452 !      print *,"SORT",short,long,sinthet,costhet
19453 !C now costhet_grad
19454 !C       costhet=0.6d0
19455 !C       sinthet=0.8
19456        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
19457 !C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
19458 !C     &             -short/dist_pep_side**2/costhet)
19459 !C       costhet_fac=0.0d0
19460        do j=1,3
19461          costhet_grad(j)=costhet_fac*pep_side(j)
19462        enddo
19463 !C remember for the final gradient multiply costhet_grad(j)
19464 !C for side_chain by factor -2 !
19465 !C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
19466 !C pep_side0pept_group is vector multiplication
19467       pep_side0pept_group=0.0d0
19468       do j=1,3
19469       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
19470       enddo
19471       cosalfa=(pep_side0pept_group/ &
19472       (dist_pep_side*dist_side_calf))
19473       fac_alfa_sin=1.0d0-cosalfa**2
19474       fac_alfa_sin=dsqrt(fac_alfa_sin)
19475       rkprim=fac_alfa_sin*(long-short)+short
19476 !C      rkprim=short
19477
19478 !C now costhet_grad
19479        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
19480 !C       cosphi=0.6
19481        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
19482        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/ &
19483            dist_pep_side**2)
19484 !C       sinphi=0.8
19485        do j=1,3
19486          cosphi_grad_long(j)=cosphi_fac*pep_side(j) &
19487       +cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19488       *(long-short)/fac_alfa_sin*cosalfa/ &
19489       ((dist_pep_side*dist_side_calf))* &
19490       ((side_calf(j))-cosalfa* &
19491       ((pep_side(j)/dist_pep_side)*dist_side_calf))
19492 !C       cosphi_grad_long(j)=0.0d0
19493         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim) &
19494       *(long-short)/fac_alfa_sin*cosalfa &
19495       /((dist_pep_side*dist_side_calf))* &
19496       (pep_side(j)- &
19497       cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
19498 !C       cosphi_grad_loc(j)=0.0d0
19499        enddo
19500 !C      print *,sinphi,sinthet
19501       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet)) &
19502                          /VSolvSphere_div
19503 !C     &                    *wshield
19504 !C now the gradient...
19505       do j=1,3
19506       grad_shield(j,i)=grad_shield(j,i) &
19507 !C gradient po skalowaniu
19508                      +(sh_frac_dist_grad(j)*VofOverlap &
19509 !C  gradient po costhet
19510             +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0* &
19511         (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*( &
19512             sinphi/sinthet*costhet*costhet_grad(j) &
19513            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19514         )*wshield
19515 !C grad_shield_side is Cbeta sidechain gradient
19516       grad_shield_side(j,ishield_list(i),i)=&
19517              (sh_frac_dist_grad(j)*-2.0d0&
19518              *VofOverlap&
19519             -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19520        (1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(&
19521             sinphi/sinthet*costhet*costhet_grad(j)&
19522            +sinthet/sinphi*cosphi*cosphi_grad_long(j))) &
19523             )*wshield
19524 !       print *, 1.0d0/(-dsqrt(1.0d0-sinphi*sinthet)),&
19525 !            sinphi/sinthet,&
19526 !           +sinthet/sinphi,"HERE"
19527        grad_shield_loc(j,ishield_list(i),i)=   &
19528             scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*&
19529       (1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(&
19530             sinthet/sinphi*cosphi*cosphi_grad_loc(j)&
19531              ))&
19532              *wshield
19533 !         print *,grad_shield_loc(j,ishield_list(i),i)
19534       enddo
19535       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
19536       enddo
19537       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
19538
19539 !      write(2,*) "TOTAL VOLUME",i,itype(i,1),fac_shield(i)
19540       enddo
19541       return
19542       end subroutine set_shield_fac2
19543 !----------------------------------------------------------------------------
19544 ! SOUBROUTINE FOR AFM
19545        subroutine AFMvel(Eafmforce)
19546        use MD_data, only:totTafm
19547       real(kind=8),dimension(3) :: diffafm
19548       real(kind=8) :: afmdist,Eafmforce
19549        integer :: i
19550 !C Only for check grad COMMENT if not used for checkgrad
19551 !C      totT=3.0d0
19552 !C--------------------------------------------------------
19553 !C      print *,"wchodze"
19554       afmdist=0.0d0
19555       Eafmforce=0.0d0
19556       do i=1,3
19557       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19558       afmdist=afmdist+diffafm(i)**2
19559       enddo
19560       afmdist=dsqrt(afmdist)
19561 !      totTafm=3.0
19562       Eafmforce=0.5d0*forceAFMconst &
19563       *(distafminit+totTafm*velAFMconst-afmdist)**2
19564 !C      Eafmforce=-forceAFMconst*(dist-distafminit)
19565       do i=1,3
19566       gradafm(i,afmend-1)=-forceAFMconst* &
19567        (distafminit+totTafm*velAFMconst-afmdist) &
19568        *diffafm(i)/afmdist
19569       gradafm(i,afmbeg-1)=forceAFMconst* &
19570       (distafminit+totTafm*velAFMconst-afmdist) &
19571       *diffafm(i)/afmdist
19572       enddo
19573 !      print *,'AFM',Eafmforce,totTafm*velAFMconst,afmdist
19574       return
19575       end subroutine AFMvel
19576 !---------------------------------------------------------
19577        subroutine AFMforce(Eafmforce)
19578
19579       real(kind=8),dimension(3) :: diffafm
19580 !      real(kind=8) ::afmdist
19581       real(kind=8) :: afmdist,Eafmforce
19582       integer :: i
19583       afmdist=0.0d0
19584       Eafmforce=0.0d0
19585       do i=1,3
19586       diffafm(i)=c(i,afmend)-c(i,afmbeg)
19587       afmdist=afmdist+diffafm(i)**2
19588       enddo
19589       afmdist=dsqrt(afmdist)
19590 !      print *,afmdist,distafminit
19591       Eafmforce=-forceAFMconst*(afmdist-distafminit)
19592       do i=1,3
19593       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/afmdist
19594       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/afmdist
19595       enddo
19596 !C      print *,'AFM',Eafmforce
19597       return
19598       end subroutine AFMforce
19599
19600 !-----------------------------------------------------------------------------
19601 #ifdef WHAM
19602       subroutine read_ssHist
19603 !      implicit none
19604 !      Includes
19605 !      include 'DIMENSIONS'
19606 !      include "DIMENSIONS.FREE"
19607 !      include 'COMMON.FREE'
19608 !     Local variables
19609       integer :: i,j
19610       character(len=80) :: controlcard
19611
19612       do i=1,dyn_nssHist
19613         call card_concat(controlcard,.true.)
19614         read(controlcard,*) &
19615              dyn_ssHist(i,0),(dyn_ssHist(i,j),j=1,2*dyn_ssHist(i,0))
19616       enddo
19617
19618       return
19619       end subroutine read_ssHist
19620 #endif
19621 !-----------------------------------------------------------------------------
19622       integer function indmat(i,j)
19623 !el
19624 ! get the position of the jth ijth fragment of the chain coordinate system
19625 ! in the fromto array.
19626         integer :: i,j
19627
19628         indmat=((2*(nres-2)-i)*(i-1))/2+j-1
19629       return
19630       end function indmat
19631 !-----------------------------------------------------------------------------
19632       real(kind=8) function sigm(x)
19633 !el
19634        real(kind=8) :: x
19635         sigm=0.25d0*x
19636       return
19637       end function sigm
19638 !-----------------------------------------------------------------------------
19639 !-----------------------------------------------------------------------------
19640       subroutine alloc_ener_arrays
19641 !EL Allocation of arrays used by module energy
19642       use MD_data, only: mset
19643 !el local variables
19644       integer :: i,j
19645
19646       if(nres.lt.100) then
19647         maxconts=nres
19648       elseif(nres.lt.200) then
19649         maxconts=0.8*nres      ! Max. number of contacts per residue
19650       else
19651         maxconts=0.6*nres ! (maxconts=maxres/4)
19652       endif
19653       maxcont=12*nres      ! Max. number of SC contacts
19654       maxvar=6*nres      ! Max. number of variables
19655 !el      maxdim=(nres-1)*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19656       maxdim=nres*(nres-2)/2 ! Max. number of derivatives of virtual-bond
19657 !----------------------
19658 ! arrays in subroutine init_int_table
19659 !el#ifdef MPI
19660 !el      allocate(itask_cont_from(0:nfgtasks-1)) !(0:max_fg_procs-1)
19661 !el      allocate(itask_cont_to(0:nfgtasks-1)) !(0:max_fg_procs-1)
19662 !el#endif
19663       allocate(nint_gr(nres))
19664       allocate(nscp_gr(nres))
19665       allocate(ielstart(nres))
19666       allocate(ielend(nres))
19667 !(maxres)
19668       allocate(istart(nres,maxint_gr))
19669       allocate(iend(nres,maxint_gr))
19670 !(maxres,maxint_gr)
19671       allocate(iscpstart(nres,maxint_gr))
19672       allocate(iscpend(nres,maxint_gr))
19673 !(maxres,maxint_gr)
19674       allocate(ielstart_vdw(nres))
19675       allocate(ielend_vdw(nres))
19676 !(maxres)
19677       allocate(nint_gr_nucl(nres))
19678       allocate(nscp_gr_nucl(nres))
19679       allocate(ielstart_nucl(nres))
19680       allocate(ielend_nucl(nres))
19681 !(maxres)
19682       allocate(istart_nucl(nres,maxint_gr))
19683       allocate(iend_nucl(nres,maxint_gr))
19684 !(maxres,maxint_gr)
19685       allocate(iscpstart_nucl(nres,maxint_gr))
19686       allocate(iscpend_nucl(nres,maxint_gr))
19687 !(maxres,maxint_gr)
19688       allocate(ielstart_vdw_nucl(nres))
19689       allocate(ielend_vdw_nucl(nres))
19690
19691       allocate(lentyp(0:nfgtasks-1))
19692 !(0:maxprocs-1)
19693 !----------------------
19694 ! commom.contacts
19695 !      common /contacts/
19696       if(.not.allocated(icont_ref)) allocate(icont_ref(2,maxcont))
19697       allocate(icont(2,maxcont))
19698 !(2,maxcont)
19699 !      common /contacts1/
19700       allocate(num_cont(0:nres+4))
19701 !(maxres)
19702       allocate(jcont(maxconts,nres))
19703 !(maxconts,maxres)
19704       allocate(facont(maxconts,nres))
19705 !(maxconts,maxres)
19706       allocate(gacont(3,maxconts,nres))
19707 !(3,maxconts,maxres)
19708 !      common /contacts_hb/
19709       allocate(gacontp_hb1(3,maxconts,nres))
19710       allocate(gacontp_hb2(3,maxconts,nres))
19711       allocate(gacontp_hb3(3,maxconts,nres))
19712       allocate(gacontm_hb1(3,maxconts,nres))
19713       allocate(gacontm_hb2(3,maxconts,nres))
19714       allocate(gacontm_hb3(3,maxconts,nres))
19715       allocate(gacont_hbr(3,maxconts,nres))
19716       allocate(grij_hb_cont(3,maxconts,nres))
19717 !(3,maxconts,maxres)
19718       allocate(facont_hb(maxconts,nres))
19719
19720       allocate(ees0p(maxconts,nres))
19721       allocate(ees0m(maxconts,nres))
19722       allocate(d_cont(maxconts,nres))
19723       allocate(ees0plist(maxconts,nres))
19724
19725 !(maxconts,maxres)
19726       allocate(num_cont_hb(nres))
19727 !(maxres)
19728       allocate(jcont_hb(maxconts,nres))
19729 !(maxconts,maxres)
19730 !      common /rotat/
19731       allocate(Ug(2,2,nres))
19732       allocate(Ugder(2,2,nres))
19733       allocate(Ug2(2,2,nres))
19734       allocate(Ug2der(2,2,nres))
19735 !(2,2,maxres)
19736       allocate(obrot(2,nres))
19737       allocate(obrot2(2,nres))
19738       allocate(obrot_der(2,nres))
19739       allocate(obrot2_der(2,nres))
19740 !(2,maxres)
19741 !      common /precomp1/
19742       allocate(mu(2,nres))
19743       allocate(muder(2,nres))
19744       allocate(Ub2(2,nres))
19745       Ub2(1,:)=0.0d0
19746       Ub2(2,:)=0.0d0
19747       allocate(Ub2der(2,nres))
19748       allocate(Ctobr(2,nres))
19749       allocate(Ctobrder(2,nres))
19750       allocate(Dtobr2(2,nres))
19751       allocate(Dtobr2der(2,nres))
19752 !(2,maxres)
19753       allocate(EUg(2,2,nres))
19754       allocate(EUgder(2,2,nres))
19755       allocate(CUg(2,2,nres))
19756       allocate(CUgder(2,2,nres))
19757       allocate(DUg(2,2,nres))
19758       allocate(Dugder(2,2,nres))
19759       allocate(DtUg2(2,2,nres))
19760       allocate(DtUg2der(2,2,nres))
19761 !(2,2,maxres)
19762 !      common /precomp2/
19763       allocate(Ug2Db1t(2,nres))
19764       allocate(Ug2Db1tder(2,nres))
19765       allocate(CUgb2(2,nres))
19766       allocate(CUgb2der(2,nres))
19767 !(2,maxres)
19768       allocate(EUgC(2,2,nres))
19769       allocate(EUgCder(2,2,nres))
19770       allocate(EUgD(2,2,nres))
19771       allocate(EUgDder(2,2,nres))
19772       allocate(DtUg2EUg(2,2,nres))
19773       allocate(Ug2DtEUg(2,2,nres))
19774 !(2,2,maxres)
19775       allocate(Ug2DtEUgder(2,2,2,nres))
19776       allocate(DtUg2EUgder(2,2,2,nres))
19777 !(2,2,2,maxres)
19778 !      common /rotat_old/
19779       allocate(costab(nres))
19780       allocate(sintab(nres))
19781       allocate(costab2(nres))
19782       allocate(sintab2(nres))
19783 !(maxres)
19784 !      common /dipmat/
19785       allocate(a_chuj(2,2,maxconts,nres))
19786 !(2,2,maxconts,maxres)(maxconts=maxres/4)
19787       allocate(a_chuj_der(2,2,3,5,maxconts,nres))
19788 !(2,2,3,5,maxconts,maxres)(maxconts=maxres/4)
19789 !      common /contdistrib/
19790       allocate(ncont_sent(nres))
19791       allocate(ncont_recv(nres))
19792
19793       allocate(iat_sent(nres))
19794 !(maxres)
19795       allocate(iint_sent(4,nres,nres))
19796       allocate(iint_sent_local(4,nres,nres))
19797 !(4,maxres,maxres)
19798       allocate(iturn3_sent(4,0:nres+4))
19799       allocate(iturn4_sent(4,0:nres+4))
19800       allocate(iturn3_sent_local(4,nres))
19801       allocate(iturn4_sent_local(4,nres))
19802 !(4,maxres)
19803       allocate(itask_cont_from(0:nfgtasks-1))
19804       allocate(itask_cont_to(0:nfgtasks-1))
19805 !(0:max_fg_procs-1)
19806
19807
19808
19809 !----------------------
19810 ! commom.deriv;
19811 !      common /derivat/
19812       allocate(dcdv(6,maxdim))
19813       allocate(dxdv(6,maxdim))
19814 !(6,maxdim)
19815       allocate(dxds(6,nres))
19816 !(6,maxres)
19817       allocate(gradx(3,-1:nres,0:2))
19818       allocate(gradc(3,-1:nres,0:2))
19819 !(3,maxres,2)
19820       allocate(gvdwx(3,-1:nres))
19821       allocate(gvdwc(3,-1:nres))
19822       allocate(gelc(3,-1:nres))
19823       allocate(gelc_long(3,-1:nres))
19824       allocate(gvdwpp(3,-1:nres))
19825       allocate(gvdwc_scpp(3,-1:nres))
19826       allocate(gradx_scp(3,-1:nres))
19827       allocate(gvdwc_scp(3,-1:nres))
19828       allocate(ghpbx(3,-1:nres))
19829       allocate(ghpbc(3,-1:nres))
19830       allocate(gradcorr(3,-1:nres))
19831       allocate(gradcorr_long(3,-1:nres))
19832       allocate(gradcorr5_long(3,-1:nres))
19833       allocate(gradcorr6_long(3,-1:nres))
19834       allocate(gcorr6_turn_long(3,-1:nres))
19835       allocate(gradxorr(3,-1:nres))
19836       allocate(gradcorr5(3,-1:nres))
19837       allocate(gradcorr6(3,-1:nres))
19838       allocate(gliptran(3,-1:nres))
19839       allocate(gliptranc(3,-1:nres))
19840       allocate(gliptranx(3,-1:nres))
19841       allocate(gshieldx(3,-1:nres))
19842       allocate(gshieldc(3,-1:nres))
19843       allocate(gshieldc_loc(3,-1:nres))
19844       allocate(gshieldx_ec(3,-1:nres))
19845       allocate(gshieldc_ec(3,-1:nres))
19846       allocate(gshieldc_loc_ec(3,-1:nres))
19847       allocate(gshieldx_t3(3,-1:nres))
19848       allocate(gshieldc_t3(3,-1:nres))
19849       allocate(gshieldc_loc_t3(3,-1:nres))
19850       allocate(gshieldx_t4(3,-1:nres))
19851       allocate(gshieldc_t4(3,-1:nres))
19852       allocate(gshieldc_loc_t4(3,-1:nres))
19853       allocate(gshieldx_ll(3,-1:nres))
19854       allocate(gshieldc_ll(3,-1:nres))
19855       allocate(gshieldc_loc_ll(3,-1:nres))
19856       allocate(grad_shield(3,-1:nres))
19857       allocate(gg_tube_sc(3,-1:nres))
19858       allocate(gg_tube(3,-1:nres))
19859       allocate(gradafm(3,-1:nres))
19860       allocate(gradb_nucl(3,-1:nres))
19861       allocate(gradbx_nucl(3,-1:nres))
19862       allocate(gvdwpsb1(3,-1:nres))
19863       allocate(gelpp(3,-1:nres))
19864       allocate(gvdwpsb(3,-1:nres))
19865       allocate(gelsbc(3,-1:nres))
19866       allocate(gelsbx(3,-1:nres))
19867       allocate(gvdwsbx(3,-1:nres))
19868       allocate(gvdwsbc(3,-1:nres))
19869       allocate(gsbloc(3,-1:nres))
19870       allocate(gsblocx(3,-1:nres))
19871       allocate(gradcorr_nucl(3,-1:nres))
19872       allocate(gradxorr_nucl(3,-1:nres))
19873       allocate(gradcorr3_nucl(3,-1:nres))
19874       allocate(gradxorr3_nucl(3,-1:nres))
19875       allocate(gvdwpp_nucl(3,-1:nres))
19876       allocate(gradpepcat(3,-1:nres))
19877       allocate(gradpepcatx(3,-1:nres))
19878       allocate(gradcatcat(3,-1:nres))
19879 !(3,maxres)
19880       allocate(grad_shield_side(3,50,nres))
19881       allocate(grad_shield_loc(3,50,nres))
19882 ! grad for shielding surroing
19883       allocate(gloc(0:maxvar,0:2))
19884       allocate(gloc_x(0:maxvar,2))
19885 !(maxvar,2)
19886       allocate(gel_loc(3,-1:nres))
19887       allocate(gel_loc_long(3,-1:nres))
19888       allocate(gcorr3_turn(3,-1:nres))
19889       allocate(gcorr4_turn(3,-1:nres))
19890       allocate(gcorr6_turn(3,-1:nres))
19891       allocate(gradb(3,-1:nres))
19892       allocate(gradbx(3,-1:nres))
19893 !(3,maxres)
19894       allocate(gel_loc_loc(maxvar))
19895       allocate(gel_loc_turn3(maxvar))
19896       allocate(gel_loc_turn4(maxvar))
19897       allocate(gel_loc_turn6(maxvar))
19898       allocate(gcorr_loc(maxvar))
19899       allocate(g_corr5_loc(maxvar))
19900       allocate(g_corr6_loc(maxvar))
19901 !(maxvar)
19902       allocate(gsccorc(3,-1:nres))
19903       allocate(gsccorx(3,-1:nres))
19904 !(3,maxres)
19905       allocate(gsccor_loc(-1:nres))
19906 !(maxres)
19907       allocate(gvdwx_scbase(3,-1:nres))
19908       allocate(gvdwc_scbase(3,-1:nres))
19909       allocate(gvdwx_pepbase(3,-1:nres))
19910       allocate(gvdwc_pepbase(3,-1:nres))
19911       allocate(gvdwx_scpho(3,-1:nres))
19912       allocate(gvdwc_scpho(3,-1:nres))
19913       allocate(gvdwc_peppho(3,-1:nres))
19914
19915       allocate(dtheta(3,2,-1:nres))
19916 !(3,2,maxres)
19917       allocate(gscloc(3,-1:nres))
19918       allocate(gsclocx(3,-1:nres))
19919 !(3,maxres)
19920       allocate(dphi(3,3,-1:nres))
19921       allocate(dalpha(3,3,-1:nres))
19922       allocate(domega(3,3,-1:nres))
19923 !(3,3,maxres)
19924 !      common /deriv_scloc/
19925       allocate(dXX_C1tab(3,nres))
19926       allocate(dYY_C1tab(3,nres))
19927       allocate(dZZ_C1tab(3,nres))
19928       allocate(dXX_Ctab(3,nres))
19929       allocate(dYY_Ctab(3,nres))
19930       allocate(dZZ_Ctab(3,nres))
19931       allocate(dXX_XYZtab(3,nres))
19932       allocate(dYY_XYZtab(3,nres))
19933       allocate(dZZ_XYZtab(3,nres))
19934 !(3,maxres)
19935 !      common /mpgrad/
19936       allocate(jgrad_start(nres))
19937       allocate(jgrad_end(nres))
19938 !(maxres)
19939 !----------------------
19940
19941 !      common /indices/
19942       allocate(ibond_displ(0:nfgtasks-1))
19943       allocate(ibond_count(0:nfgtasks-1))
19944       allocate(ithet_displ(0:nfgtasks-1))
19945       allocate(ithet_count(0:nfgtasks-1))
19946       allocate(iphi_displ(0:nfgtasks-1))
19947       allocate(iphi_count(0:nfgtasks-1))
19948       allocate(iphi1_displ(0:nfgtasks-1))
19949       allocate(iphi1_count(0:nfgtasks-1))
19950       allocate(ivec_displ(0:nfgtasks-1))
19951       allocate(ivec_count(0:nfgtasks-1))
19952       allocate(iset_displ(0:nfgtasks-1))
19953       allocate(iset_count(0:nfgtasks-1))
19954       allocate(iint_count(0:nfgtasks-1))
19955       allocate(iint_displ(0:nfgtasks-1))
19956 !(0:max_fg_procs-1)
19957 !----------------------
19958 ! common.MD
19959 !      common /mdgrad/
19960       allocate(gcart(3,-1:nres))
19961       allocate(gxcart(3,-1:nres))
19962 !(3,0:MAXRES)
19963       allocate(gradcag(3,-1:nres))
19964       allocate(gradxag(3,-1:nres))
19965 !(3,MAXRES)
19966 !      common /back_constr/
19967 !el in energy:Econstr_back   allocate((:),allocatable :: utheta,ugamma,uscdiff !(maxfrag_back)
19968       allocate(dutheta(nres))
19969       allocate(dugamma(nres))
19970 !(maxres)
19971       allocate(duscdiff(3,nres))
19972       allocate(duscdiffx(3,nres))
19973 !(3,maxres)
19974 !el i io:read_fragments
19975 !      allocate((:,:,:),allocatable :: wfrag_back !(3,maxfrag_back,maxprocs/20)
19976 !      allocate((:,:,:),allocatable :: ifrag_back !(3,maxfrag_back,maxprocs/20)
19977 !      common /qmeas/
19978 !      allocate(qinfrag(50,nprocs/20),wfrag(50,nprocs/20)) !(50,maxprocs/20)
19979 !      allocate(qinpair(100,nprocs/20),wpair(100,nprocs/20)) !(100,maxprocs/20)
19980       allocate(mset(0:nprocs))  !(maxprocs/20)
19981       mset(:)=0
19982 !      allocate(ifrag(2,50,nprocs/20))  !(2,50,maxprocs/20)
19983 !      allocate(ipair(2,100,nprocs/20))  !(2,100,maxprocs/20)
19984       allocate(dUdconst(3,0:nres))
19985       allocate(dUdxconst(3,0:nres))
19986       allocate(dqwol(3,0:nres))
19987       allocate(dxqwol(3,0:nres))
19988 !(3,0:MAXRES)
19989 !----------------------
19990 ! common.sbridge
19991 !      common /sbridge/ in io_common: read_bridge
19992 !el    allocate((:),allocatable :: iss      !(maxss)
19993 !      common /links/  in io_common: read_bridge
19994 !el      real(kind=8),dimension(:),allocatable :: dhpb,forcon,dhpb1 !(maxdim) !el dhpb1 !!! nie używane
19995 !el      integer,dimension(:),allocatable :: ihpb,jhpb,ibecarb !(maxdim) !el ibecarb !!! nie używane
19996 !      common /dyn_ssbond/
19997 ! and side-chain vectors in theta or phi.
19998       allocate(dyn_ssbond_ij(0:nres+4,0:nres+4))
19999 !(maxres,maxres)
20000 !      do i=1,nres
20001 !        do j=i+1,nres
20002       dyn_ssbond_ij(:,:)=1.0d300
20003 !        enddo
20004 !      enddo
20005
20006 !      if (nss.gt.0) then
20007         allocate(idssb(maxdim),jdssb(maxdim))
20008 !        allocate(newihpb(nss),newjhpb(nss))
20009 !(maxdim)
20010 !      endif
20011       allocate(ishield_list(nres))
20012       allocate(shield_list(50,nres))
20013       allocate(dyn_ss_mask(nres))
20014       allocate(fac_shield(nres))
20015       allocate(enetube(nres*2))
20016       allocate(enecavtube(nres*2))
20017
20018 !(maxres)
20019       dyn_ss_mask(:)=.false.
20020 !----------------------
20021 ! common.sccor
20022 ! Parameters of the SCCOR term
20023 !      common/sccor/
20024 !el in io_conf: parmread
20025 !      allocate(v1sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp))
20026 !      allocate(v2sccor(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,3,-ntyp:ntyp,-ntyp:ntyp)
20027 !      allocate(v0sccor(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)) !(maxterm_sccor,-ntyp:ntyp,-ntyp:ntyp)
20028 !      allocate(isccortyp(-ntyp:ntyp)) !(-ntyp:ntyp)
20029 !      allocate(nterm_sccor(-ntyp:ntyp,-ntyp:ntyp))
20030 !      allocate(nlor_sccor(-ntyp:ntyp,-ntyp:ntyp)) !(-ntyp:ntyp,-ntyp:ntyp)
20031 !      allocate(vlor1sccor(maxterm_sccor,20,20))
20032 !      allocate(vlor2sccor(maxterm_sccor,20,20))
20033 !      allocate(vlor3sccor(maxterm_sccor,20,20))      !(maxterm_sccor,20,20)
20034 !----------------
20035       allocate(gloc_sc(3,0:2*nres,0:10))
20036 !(3,0:maxres2,10)maxres2=2*maxres
20037       allocate(dcostau(3,3,3,2*nres))
20038       allocate(dsintau(3,3,3,2*nres))
20039       allocate(dtauangle(3,3,3,2*nres))
20040       allocate(dcosomicron(3,3,3,2*nres))
20041       allocate(domicron(3,3,3,2*nres))
20042 !(3,3,3,maxres2)maxres2=2*maxres
20043 !----------------------
20044 ! common.var
20045 !      common /restr/
20046       allocate(varall(maxvar))
20047 !(maxvar)(maxvar=6*maxres)
20048       allocate(mask_theta(nres))
20049       allocate(mask_phi(nres))
20050       allocate(mask_side(nres))
20051 !(maxres)
20052 !----------------------
20053 ! common.vectors
20054 !      common /vectors/
20055       allocate(uy(3,nres))
20056       allocate(uz(3,nres))
20057 !(3,maxres)
20058       allocate(uygrad(3,3,2,nres))
20059       allocate(uzgrad(3,3,2,nres))
20060 !(3,3,2,maxres)
20061
20062       return
20063       end subroutine alloc_ener_arrays
20064 !-----------------------------------------------------------------
20065       subroutine ebond_nucl(estr_nucl)
20066 !c
20067 !c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
20068 !c
20069
20070       real(kind=8),dimension(3) :: u,ud
20071       real(kind=8) :: usum,uprod,uprod1,uprod2,usumsqder
20072       real(kind=8) :: estr_nucl,diff
20073       integer :: iti,i,j,k,nbi
20074       estr_nucl=0.0d0
20075 !C      print *,"I enter ebond"
20076       if (energy_dec) &
20077       write (iout,*) "ibondp_start,ibondp_end",&
20078        ibondp_nucl_start,ibondp_nucl_end
20079       do i=ibondp_nucl_start,ibondp_nucl_end
20080         if (itype(i-1,2).eq.ntyp1_molec(2) .or. &
20081          itype(i,2).eq.ntyp1_molec(2)) cycle
20082 !          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
20083 !          do j=1,3
20084 !          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
20085 !     &      *dc(j,i-1)/vbld(i)
20086 !          enddo
20087 !          if (energy_dec) write(iout,*)
20088 !     &       "estr1",i,vbld(i),distchainmax,
20089 !     &       gnmr1(vbld(i),-1.0d0,distchainmax)
20090
20091           diff = vbld(i)-vbldp0_nucl
20092           if(energy_dec)write(iout,*) "estr_nucl_bb" , i,vbld(i),&
20093           vbldp0_nucl,diff,AKP_nucl*diff*diff
20094           estr_nucl=estr_nucl+diff*diff
20095 !          print *,estr_nucl
20096           do j=1,3
20097             gradb_nucl(j,i-1)=AKP_nucl*diff*dc(j,i-1)/vbld(i)
20098           enddo
20099 !c          write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
20100       enddo
20101       estr_nucl=0.5d0*AKP_nucl*estr_nucl
20102 !      print *,"partial sum", estr_nucl,AKP_nucl
20103
20104       if (energy_dec) &
20105       write (iout,*) "ibondp_start,ibondp_end",&
20106        ibond_nucl_start,ibond_nucl_end
20107
20108       do i=ibond_nucl_start,ibond_nucl_end
20109 !C        print *, "I am stuck",i
20110         iti=itype(i,2)
20111         if (iti.eq.ntyp1_molec(2)) cycle
20112           nbi=nbondterm_nucl(iti)
20113 !C        print *,iti,nbi
20114           if (nbi.eq.1) then
20115             diff=vbld(i+nres)-vbldsc0_nucl(1,iti)
20116
20117             if (energy_dec) &
20118            write (iout,*) "estr_nucl_sc", i,iti,vbld(i+nres),vbldsc0_nucl(1,iti),diff, &
20119            AKSC_nucl(1,iti),AKSC_nucl(1,iti)*diff*diff
20120             estr_nucl=estr_nucl+0.5d0*AKSC_nucl(1,iti)*diff*diff
20121 !            print *,estr_nucl
20122             do j=1,3
20123               gradbx_nucl(j,i)=AKSC_nucl(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
20124             enddo
20125           else
20126             do j=1,nbi
20127               diff=vbld(i+nres)-vbldsc0_nucl(j,iti)
20128               ud(j)=aksc_nucl(j,iti)*diff
20129               u(j)=abond0_nucl(j,iti)+0.5d0*ud(j)*diff
20130             enddo
20131             uprod=u(1)
20132             do j=2,nbi
20133               uprod=uprod*u(j)
20134             enddo
20135             usum=0.0d0
20136             usumsqder=0.0d0
20137             do j=1,nbi
20138               uprod1=1.0d0
20139               uprod2=1.0d0
20140               do k=1,nbi
20141                 if (k.ne.j) then
20142                   uprod1=uprod1*u(k)
20143                   uprod2=uprod2*u(k)*u(k)
20144                 endif
20145               enddo
20146               usum=usum+uprod1
20147               usumsqder=usumsqder+ud(j)*uprod2
20148             enddo
20149             estr_nucl=estr_nucl+uprod/usum
20150             do j=1,3
20151              gradbx_nucl(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
20152             enddo
20153         endif
20154       enddo
20155 !C      print *,"I am about to leave ebond"
20156       return
20157       end subroutine ebond_nucl
20158
20159 !-----------------------------------------------------------------------------
20160       subroutine ebend_nucl(etheta_nucl)
20161       real(kind=8),dimension(nntheterm_nucl+1) :: coskt,sinkt !mmaxtheterm
20162       real(kind=8),dimension(nsingle_nucl+1) :: cosph1,sinph1,cosph2,sinph2 !maxsingle
20163       real(kind=8),dimension(ndouble_nucl+1,ndouble_nucl+1) :: cosph1ph2,sinph1ph2 !maxdouble,maxdouble
20164       logical :: lprn=.false., lprn1=.false.
20165 !el local variables
20166       integer :: i,k,iblock,ityp1,ityp2,ityp3,l,m
20167       real(kind=8) :: dethetai,dephii,dephii1,theti2,phii,phii1,ethetai
20168       real(kind=8) :: aux,etheta_nucl,ccl,ssl,scl,csl,ethetacnstr
20169 ! local variables for constrains
20170       real(kind=8) :: difi,thetiii
20171        integer itheta
20172       etheta_nucl=0.0D0
20173 !      print *,"ithet_start",ithet_nucl_start," ithet_end",ithet_nucl_end,nres
20174       do i=ithet_nucl_start,ithet_nucl_end
20175         if ((itype(i-1,2).eq.ntyp1_molec(2)).or.&
20176         (itype(i-2,2).eq.ntyp1_molec(2)).or.     &
20177         (itype(i,2).eq.ntyp1_molec(2))) cycle
20178         dethetai=0.0d0
20179         dephii=0.0d0
20180         dephii1=0.0d0
20181         theti2=0.5d0*theta(i)
20182         ityp2=ithetyp_nucl(itype(i-1,2))
20183         do k=1,nntheterm_nucl
20184           coskt(k)=dcos(k*theti2)
20185           sinkt(k)=dsin(k*theti2)
20186         enddo
20187         if (i.gt.3 .and. itype(i-2,2).ne.ntyp1_molec(2)) then
20188 #ifdef OSF
20189           phii=phi(i)
20190           if (phii.ne.phii) phii=150.0
20191 #else
20192           phii=phi(i)
20193 #endif
20194           ityp1=ithetyp_nucl(itype(i-2,2))
20195           do k=1,nsingle_nucl
20196             cosph1(k)=dcos(k*phii)
20197             sinph1(k)=dsin(k*phii)
20198           enddo
20199         else
20200           phii=0.0d0
20201           ityp1=nthetyp_nucl+1
20202           do k=1,nsingle_nucl
20203             cosph1(k)=0.0d0
20204             sinph1(k)=0.0d0
20205           enddo
20206         endif
20207
20208         if (i.lt.nres .and. itype(i,2).ne.ntyp1_molec(2)) then
20209 #ifdef OSF
20210           phii1=phi(i+1)
20211           if (phii1.ne.phii1) phii1=150.0
20212           phii1=pinorm(phii1)
20213 #else
20214           phii1=phi(i+1)
20215 #endif
20216           ityp3=ithetyp_nucl(itype(i,2))
20217           do k=1,nsingle_nucl
20218             cosph2(k)=dcos(k*phii1)
20219             sinph2(k)=dsin(k*phii1)
20220           enddo
20221         else
20222           phii1=0.0d0
20223           ityp3=nthetyp_nucl+1
20224           do k=1,nsingle_nucl
20225             cosph2(k)=0.0d0
20226             sinph2(k)=0.0d0
20227           enddo
20228         endif
20229         ethetai=aa0thet_nucl(ityp1,ityp2,ityp3)
20230         do k=1,ndouble_nucl
20231           do l=1,k-1
20232             ccl=cosph1(l)*cosph2(k-l)
20233             ssl=sinph1(l)*sinph2(k-l)
20234             scl=sinph1(l)*cosph2(k-l)
20235             csl=cosph1(l)*sinph2(k-l)
20236             cosph1ph2(l,k)=ccl-ssl
20237             cosph1ph2(k,l)=ccl+ssl
20238             sinph1ph2(l,k)=scl+csl
20239             sinph1ph2(k,l)=scl-csl
20240           enddo
20241         enddo
20242         if (lprn) then
20243         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,&
20244          " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
20245         write (iout,*) "coskt and sinkt",nntheterm_nucl
20246         do k=1,nntheterm_nucl
20247           write (iout,*) k,coskt(k),sinkt(k)
20248         enddo
20249         endif
20250         do k=1,ntheterm_nucl
20251           ethetai=ethetai+aathet_nucl(k,ityp1,ityp2,ityp3)*sinkt(k)
20252           dethetai=dethetai+0.5d0*k*aathet_nucl(k,ityp1,ityp2,ityp3)&
20253            *coskt(k)
20254           if (lprn)&
20255          write (iout,*) "k",k," aathet",aathet_nucl(k,ityp1,ityp2,ityp3),&
20256           " ethetai",ethetai
20257         enddo
20258         if (lprn) then
20259         write (iout,*) "cosph and sinph"
20260         do k=1,nsingle_nucl
20261           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
20262         enddo
20263         write (iout,*) "cosph1ph2 and sinph2ph2"
20264         do k=2,ndouble_nucl
20265           do l=1,k-1
20266             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),&
20267               sinph1ph2(l,k),sinph1ph2(k,l)
20268           enddo
20269         enddo
20270         write(iout,*) "ethetai",ethetai
20271         endif
20272         do m=1,ntheterm2_nucl
20273           do k=1,nsingle_nucl
20274             aux=bbthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)&
20275               +ccthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k)&
20276               +ddthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)&
20277               +eethet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k)
20278             ethetai=ethetai+sinkt(m)*aux
20279             dethetai=dethetai+0.5d0*m*aux*coskt(m)
20280             dephii=dephii+k*sinkt(m)*(&
20281                ccthet_nucl(k,m,ityp1,ityp2,ityp3)*cosph1(k)-&
20282                bbthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph1(k))
20283             dephii1=dephii1+k*sinkt(m)*(&
20284                eethet_nucl(k,m,ityp1,ityp2,ityp3)*cosph2(k)-&
20285                ddthet_nucl(k,m,ityp1,ityp2,ityp3)*sinph2(k))
20286             if (lprn) &
20287            write (iout,*) "m",m," k",k," bbthet",&
20288               bbthet_nucl(k,m,ityp1,ityp2,ityp3)," ccthet",&
20289               ccthet_nucl(k,m,ityp1,ityp2,ityp3)," ddthet",&
20290               ddthet_nucl(k,m,ityp1,ityp2,ityp3)," eethet",&
20291               eethet_nucl(k,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20292           enddo
20293         enddo
20294         if (lprn) &
20295         write(iout,*) "ethetai",ethetai
20296         do m=1,ntheterm3_nucl
20297           do k=2,ndouble_nucl
20298             do l=1,k-1
20299               aux=ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20300                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l)+&
20301                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20302                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)
20303               ethetai=ethetai+sinkt(m)*aux
20304               dethetai=dethetai+0.5d0*m*coskt(m)*aux
20305               dephii=dephii+l*sinkt(m)*(&
20306                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)-&
20307                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20308                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)+&
20309                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20310               dephii1=dephii1+(k-l)*sinkt(m)*( &
20311                 -ffthet_nucl(l,k,m,ityp1,ityp2,ityp3)*sinph1ph2(l,k)+&
20312                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)*sinph1ph2(k,l)+&
20313                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3)*cosph1ph2(l,k)-&
20314                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)*cosph1ph2(k,l))
20315               if (lprn) then
20316               write (iout,*) "m",m," k",k," l",l," ffthet", &
20317                  ffthet_nucl(l,k,m,ityp1,ityp2,ityp3), &
20318                  ffthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ggthet",&
20319                  ggthet_nucl(l,k,m,ityp1,ityp2,ityp3),&
20320                  ggthet_nucl(k,l,m,ityp1,ityp2,ityp3)," ethetai",ethetai
20321               write (iout,*) cosph1ph2(l,k)*sinkt(m), &
20322                  cosph1ph2(k,l)*sinkt(m),&
20323                  sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
20324               endif
20325             enddo
20326           enddo
20327         enddo
20328 10      continue
20329         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)') &
20330         i,theta(i)*rad2deg,phii*rad2deg, &
20331         phii1*rad2deg,ethetai
20332         etheta_nucl=etheta_nucl+ethetai
20333 !        print *,i,"partial sum",etheta_nucl
20334         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang_nucl*dephii
20335         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang_nucl*dephii1
20336         gloc(nphi+i-2,icg)=wang_nucl*dethetai
20337       enddo
20338       return
20339       end subroutine ebend_nucl
20340 !----------------------------------------------------
20341       subroutine etor_nucl(etors_nucl)
20342 !      implicit real*8 (a-h,o-z)
20343 !      include 'DIMENSIONS'
20344 !      include 'COMMON.VAR'
20345 !      include 'COMMON.GEO'
20346 !      include 'COMMON.LOCAL'
20347 !      include 'COMMON.TORSION'
20348 !      include 'COMMON.INTERACT'
20349 !      include 'COMMON.DERIV'
20350 !      include 'COMMON.CHAIN'
20351 !      include 'COMMON.NAMES'
20352 !      include 'COMMON.IOUNITS'
20353 !      include 'COMMON.FFIELD'
20354 !      include 'COMMON.TORCNSTR'
20355 !      include 'COMMON.CONTROL'
20356       real(kind=8) :: etors_nucl,edihcnstr
20357       logical :: lprn
20358 !el local variables
20359       integer :: i,j,iblock,itori,itori1
20360       real(kind=8) :: phii,gloci,v1ij,v2ij,cosphi,sinphi,&
20361                    vl1ij,vl2ij,vl3ij,pom1,difi,etors_ii,pom
20362 ! Set lprn=.true. for debugging
20363       lprn=.false.
20364 !     lprn=.true.
20365       etors_nucl=0.0D0
20366 !      print *,"iphi_nucl_start/end", iphi_nucl_start,iphi_nucl_end
20367       do i=iphi_nucl_start,iphi_nucl_end
20368         if (itype(i-2,2).eq.ntyp1_molec(2) .or. itype(i-1,2).eq.ntyp1_molec(2) &
20369              .or. itype(i-3,2).eq.ntyp1_molec(2) &
20370              .or. itype(i,2).eq.ntyp1_molec(2)) cycle
20371         etors_ii=0.0D0
20372         itori=itortyp_nucl(itype(i-2,2))
20373         itori1=itortyp_nucl(itype(i-1,2))
20374         phii=phi(i)
20375 !         print *,i,itori,itori1
20376         gloci=0.0D0
20377 !C Regular cosine and sine terms
20378         do j=1,nterm_nucl(itori,itori1)
20379           v1ij=v1_nucl(j,itori,itori1)
20380           v2ij=v2_nucl(j,itori,itori1)
20381           cosphi=dcos(j*phii)
20382           sinphi=dsin(j*phii)
20383           etors_nucl=etors_nucl+v1ij*cosphi+v2ij*sinphi
20384           if (energy_dec) etors_ii=etors_ii+&
20385                      v1ij*cosphi+v2ij*sinphi
20386           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
20387         enddo
20388 !C Lorentz terms
20389 !C                         v1
20390 !C  E = SUM ----------------------------------- - v1
20391 !C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
20392 !C
20393         cosphi=dcos(0.5d0*phii)
20394         sinphi=dsin(0.5d0*phii)
20395         do j=1,nlor_nucl(itori,itori1)
20396           vl1ij=vlor1_nucl(j,itori,itori1)
20397           vl2ij=vlor2_nucl(j,itori,itori1)
20398           vl3ij=vlor3_nucl(j,itori,itori1)
20399           pom=vl2ij*cosphi+vl3ij*sinphi
20400           pom1=1.0d0/(pom*pom+1.0d0)
20401           etors_nucl=etors_nucl+vl1ij*pom1
20402           if (energy_dec) etors_ii=etors_ii+ &
20403                      vl1ij*pom1
20404           pom=-pom*pom1*pom1
20405           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
20406         enddo
20407 !C Subtract the constant term
20408         etors_nucl=etors_nucl-v0_nucl(itori,itori1)
20409           if (energy_dec) write (iout,'(a6,i5,0pf7.3)') &
20410               'etor',i,etors_ii-v0_nucl(itori,itori1)
20411         if (lprn) &
20412        write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)') &
20413        restyp(itype(i-2,2),2),i-2,restyp(itype(i-1,2),2),i-1,itori,itori1, &
20414        (v1_nucl(j,itori,itori1),j=1,6),(v2_nucl(j,itori,itori1),j=1,6)
20415         gloc(i-3,icg)=gloc(i-3,icg)+wtor_nucl*gloci
20416 !c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
20417       enddo
20418       return
20419       end subroutine etor_nucl
20420 !------------------------------------------------------------
20421       subroutine epp_nucl_sub(evdw1,ees)
20422 !C
20423 !C This subroutine calculates the average interaction energy and its gradient
20424 !C in the virtual-bond vectors between non-adjacent peptide groups, based on
20425 !C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
20426 !C The potential depends both on the distance of peptide-group centers and on
20427 !C the orientation of the CA-CA virtual bonds.
20428 !C
20429       integer :: i,j,k,iteli,itelj,num_conti,isubchap,ind
20430       real(kind=8) :: dxi,dyi,dzi,dxj,dyj,dzj,aaa,bbb
20431       real(kind=8) :: xj,yj,zj,rij,rrmij,sss,r3ij,r6ij,evdw1,&
20432                  dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,&
20433                  dx_normj,dy_normj,dz_normj,rmij,ev1,ev2,evdwij,facvdw
20434       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20435                     dist_temp, dist_init,sss_grad,fac,evdw1ij
20436       integer xshift,yshift,zshift
20437       real(kind=8),dimension(3):: ggg,gggp,gggm,erij
20438       real(kind=8) :: ees,eesij
20439 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20440       real(kind=8) scal_el /0.5d0/
20441       t_eelecij=0.0d0
20442       ees=0.0D0
20443       evdw1=0.0D0
20444       ind=0
20445 !c
20446 !c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
20447 !c
20448 !      print *,"iatel_s_nucl,iatel_e_nucl",iatel_s_nucl,iatel_e_nucl
20449       do i=iatel_s_nucl,iatel_e_nucl
20450         if (itype(i,2).eq.ntyp1_molec(2) .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20451         dxi=dc(1,i)
20452         dyi=dc(2,i)
20453         dzi=dc(3,i)
20454         dx_normi=dc_norm(1,i)
20455         dy_normi=dc_norm(2,i)
20456         dz_normi=dc_norm(3,i)
20457         xmedi=c(1,i)+0.5d0*dxi
20458         ymedi=c(2,i)+0.5d0*dyi
20459         zmedi=c(3,i)+0.5d0*dzi
20460           xmedi=dmod(xmedi,boxxsize)
20461           if (xmedi.lt.0) xmedi=xmedi+boxxsize
20462           ymedi=dmod(ymedi,boxysize)
20463           if (ymedi.lt.0) ymedi=ymedi+boxysize
20464           zmedi=dmod(zmedi,boxzsize)
20465           if (zmedi.lt.0) zmedi=zmedi+boxzsize
20466
20467         do j=ielstart_nucl(i),ielend_nucl(i)
20468           if (itype(j,2).eq.ntyp1_molec(2) .or. itype(j+1,2).eq.ntyp1_molec(2)) cycle
20469           ind=ind+1
20470           dxj=dc(1,j)
20471           dyj=dc(2,j)
20472           dzj=dc(3,j)
20473 !          xj=c(1,j)+0.5D0*dxj-xmedi
20474 !          yj=c(2,j)+0.5D0*dyj-ymedi
20475 !          zj=c(3,j)+0.5D0*dzj-zmedi
20476           xj=c(1,j)+0.5D0*dxj
20477           yj=c(2,j)+0.5D0*dyj
20478           zj=c(3,j)+0.5D0*dzj
20479           xj=mod(xj,boxxsize)
20480           if (xj.lt.0) xj=xj+boxxsize
20481           yj=mod(yj,boxysize)
20482           if (yj.lt.0) yj=yj+boxysize
20483           zj=mod(zj,boxzsize)
20484           if (zj.lt.0) zj=zj+boxzsize
20485       isubchap=0
20486       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20487       xj_safe=xj
20488       yj_safe=yj
20489       zj_safe=zj
20490       do xshift=-1,1
20491       do yshift=-1,1
20492       do zshift=-1,1
20493           xj=xj_safe+xshift*boxxsize
20494           yj=yj_safe+yshift*boxysize
20495           zj=zj_safe+zshift*boxzsize
20496           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
20497           if(dist_temp.lt.dist_init) then
20498             dist_init=dist_temp
20499             xj_temp=xj
20500             yj_temp=yj
20501             zj_temp=zj
20502             isubchap=1
20503           endif
20504        enddo
20505        enddo
20506        enddo
20507        if (isubchap.eq.1) then
20508 !C          print *,i,j
20509           xj=xj_temp-xmedi
20510           yj=yj_temp-ymedi
20511           zj=zj_temp-zmedi
20512        else
20513           xj=xj_safe-xmedi
20514           yj=yj_safe-ymedi
20515           zj=zj_safe-zmedi
20516        endif
20517
20518           rij=xj*xj+yj*yj+zj*zj
20519 !c          write (2,*)"ij",i,j," r0pp",r0pp," rij",rij," epspp",epspp
20520           fac=(r0pp**2/rij)**3
20521           ev1=epspp*fac*fac
20522           ev2=epspp*fac
20523           evdw1ij=ev1-2*ev2
20524           fac=(-ev1-evdw1ij)/rij
20525 !          write (2,*)"fac",fac," ev1",ev1," ev2",ev2," evdw1ij",evdw1ij
20526           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"evdw1ij",evdw1ij
20527           evdw1=evdw1+evdw1ij
20528 !C
20529 !C Calculate contributions to the Cartesian gradient.
20530 !C
20531           ggg(1)=fac*xj
20532           ggg(2)=fac*yj
20533           ggg(3)=fac*zj
20534           do k=1,3
20535             gvdwpp_nucl(k,i)=gvdwpp_nucl(k,i)-ggg(k)
20536             gvdwpp_nucl(k,j)=gvdwpp_nucl(k,j)+ggg(k)
20537           enddo
20538 !c phoshate-phosphate electrostatic interactions
20539           rij=dsqrt(rij)
20540           fac=1.0d0/rij
20541           eesij=dexp(-BEES*rij)*fac
20542 !          write (2,*)"fac",fac," eesijpp",eesij
20543           if (energy_dec) write(iout,'(2i5,a9,f10.4)') i,j,"eesijpp",eesij
20544           ees=ees+eesij
20545 !c          fac=-eesij*fac
20546           fac=-(fac+BEES)*eesij*fac
20547           ggg(1)=fac*xj
20548           ggg(2)=fac*yj
20549           ggg(3)=fac*zj
20550 !c          write(2,*) "ggg",i,j,ggg(1),ggg(2),ggg(3)
20551 !c          write(2,*) "gelpp",i,(gelpp(k,i),k=1,3)
20552 !c          write(2,*) "gelpp",j,(gelpp(k,j),k=1,3)
20553           do k=1,3
20554             gelpp(k,i)=gelpp(k,i)-ggg(k)
20555             gelpp(k,j)=gelpp(k,j)+ggg(k)
20556           enddo
20557         enddo ! j
20558       enddo   ! i
20559 !c      ees=332.0d0*ees
20560       ees=AEES*ees
20561       do i=nnt,nct
20562 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20563         do k=1,3
20564           gvdwpp_nucl(k,i)=6*gvdwpp_nucl(k,i)
20565 !c          gelpp(k,i)=332.0d0*gelpp(k,i)
20566           gelpp(k,i)=AEES*gelpp(k,i)
20567         enddo
20568 !c        write (2,*) "i",i," gelpp",(gelpp(k,i),k=1,3)
20569       enddo
20570 !c      write (2,*) "total EES",ees
20571       return
20572       end subroutine epp_nucl_sub
20573 !---------------------------------------------------------------------
20574       subroutine epsb(evdwpsb,eelpsb)
20575 !      use comm_locel
20576 !C
20577 !C This subroutine calculates the excluded-volume interaction energy between
20578 !C peptide-group centers and side chains and its gradient in virtual-bond and
20579 !C side-chain vectors.
20580 !C
20581       real(kind=8),dimension(3):: ggg
20582       integer :: i,iint,j,k,iteli,itypj,subchap
20583       real(kind=8) :: evdw2,evdw2_14,xi,yi,zi,xj,yj,zj,rrij,fac,&
20584                    e1,e2,evdwij,rij,evdwpsb,eelpsb
20585       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20586                     dist_temp, dist_init
20587       integer xshift,yshift,zshift
20588
20589 !cd    print '(a)','Enter ESCP'
20590 !cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
20591       eelpsb=0.0d0
20592       evdwpsb=0.0d0
20593 !      print *,"iatscp_s_nucl,iatscp_e_nucl",iatscp_s_nucl,iatscp_e_nucl
20594       do i=iatscp_s_nucl,iatscp_e_nucl
20595         if (itype(i,2).eq.ntyp1_molec(2) &
20596          .or. itype(i+1,2).eq.ntyp1_molec(2)) cycle
20597         xi=0.5D0*(c(1,i)+c(1,i+1))
20598         yi=0.5D0*(c(2,i)+c(2,i+1))
20599         zi=0.5D0*(c(3,i)+c(3,i+1))
20600           xi=mod(xi,boxxsize)
20601           if (xi.lt.0) xi=xi+boxxsize
20602           yi=mod(yi,boxysize)
20603           if (yi.lt.0) yi=yi+boxysize
20604           zi=mod(zi,boxzsize)
20605           if (zi.lt.0) zi=zi+boxzsize
20606
20607         do iint=1,nscp_gr_nucl(i)
20608
20609         do j=iscpstart_nucl(i,iint),iscpend_nucl(i,iint)
20610           itypj=itype(j,2)
20611           if (itypj.eq.ntyp1_molec(2)) cycle
20612 !C Uncomment following three lines for SC-p interactions
20613 !c         xj=c(1,nres+j)-xi
20614 !c         yj=c(2,nres+j)-yi
20615 !c         zj=c(3,nres+j)-zi
20616 !C Uncomment following three lines for Ca-p interactions
20617 !          xj=c(1,j)-xi
20618 !          yj=c(2,j)-yi
20619 !          zj=c(3,j)-zi
20620           xj=c(1,j)
20621           yj=c(2,j)
20622           zj=c(3,j)
20623           xj=mod(xj,boxxsize)
20624           if (xj.lt.0) xj=xj+boxxsize
20625           yj=mod(yj,boxysize)
20626           if (yj.lt.0) yj=yj+boxysize
20627           zj=mod(zj,boxzsize)
20628           if (zj.lt.0) zj=zj+boxzsize
20629       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20630       xj_safe=xj
20631       yj_safe=yj
20632       zj_safe=zj
20633       subchap=0
20634       do xshift=-1,1
20635       do yshift=-1,1
20636       do zshift=-1,1
20637           xj=xj_safe+xshift*boxxsize
20638           yj=yj_safe+yshift*boxysize
20639           zj=zj_safe+zshift*boxzsize
20640           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20641           if(dist_temp.lt.dist_init) then
20642             dist_init=dist_temp
20643             xj_temp=xj
20644             yj_temp=yj
20645             zj_temp=zj
20646             subchap=1
20647           endif
20648        enddo
20649        enddo
20650        enddo
20651        if (subchap.eq.1) then
20652           xj=xj_temp-xi
20653           yj=yj_temp-yi
20654           zj=zj_temp-zi
20655        else
20656           xj=xj_safe-xi
20657           yj=yj_safe-yi
20658           zj=zj_safe-zi
20659        endif
20660
20661           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20662           fac=rrij**expon2
20663           e1=fac*fac*aad_nucl(itypj)
20664           e2=fac*bad_nucl(itypj)
20665           if (iabs(j-i) .le. 2) then
20666             e1=scal14*e1
20667             e2=scal14*e2
20668           endif
20669           evdwij=e1+e2
20670           evdwpsb=evdwpsb+evdwij
20671           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a4)') &
20672              'evdw2',i,j,evdwij,"tu4"
20673 !C
20674 !C Calculate contributions to the gradient in the virtual-bond and SC vectors.
20675 !C
20676           fac=-(evdwij+e1)*rrij
20677           ggg(1)=xj*fac
20678           ggg(2)=yj*fac
20679           ggg(3)=zj*fac
20680           do k=1,3
20681             gvdwpsb1(k,i)=gvdwpsb1(k,i)-ggg(k)
20682             gvdwpsb(k,j)=gvdwpsb(k,j)+ggg(k)
20683           enddo
20684         enddo
20685
20686         enddo ! iint
20687       enddo ! i
20688       do i=1,nct
20689         do j=1,3
20690           gvdwpsb(j,i)=expon*gvdwpsb(j,i)
20691           gvdwpsb1(j,i)=expon*gvdwpsb1(j,i)
20692         enddo
20693       enddo
20694       return
20695       end subroutine epsb
20696
20697 !------------------------------------------------------
20698       subroutine esb_gb(evdwsb,eelsb)
20699       use comm_locel
20700       use calc_data_nucl
20701       integer :: iint,itypi,itypi1,itypj,subchap,num_conti2
20702       real(kind=8) :: xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
20703       real(kind=8) :: evdw,sig0iji,evdwsb,eelsb,ecorr,eelij
20704       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20705                     dist_temp, dist_init,aa,bb,faclip,sig0ij
20706       integer :: ii
20707       logical lprn
20708       evdw=0.0D0
20709       eelsb=0.0d0
20710       ecorr=0.0d0
20711       evdwsb=0.0D0
20712       lprn=.false.
20713       ind=0
20714 !      print *,"iastsc_nucl",iatsc_s_nucl,iatsc_e_nucl
20715       do i=iatsc_s_nucl,iatsc_e_nucl
20716         num_conti=0
20717         num_conti2=0
20718         itypi=itype(i,2)
20719 !        PRINT *,"I=",i,itypi
20720         if (itypi.eq.ntyp1_molec(2)) cycle
20721         itypi1=itype(i+1,2)
20722         xi=c(1,nres+i)
20723         yi=c(2,nres+i)
20724         zi=c(3,nres+i)
20725           xi=dmod(xi,boxxsize)
20726           if (xi.lt.0) xi=xi+boxxsize
20727           yi=dmod(yi,boxysize)
20728           if (yi.lt.0) yi=yi+boxysize
20729           zi=dmod(zi,boxzsize)
20730           if (zi.lt.0) zi=zi+boxzsize
20731
20732         dxi=dc_norm(1,nres+i)
20733         dyi=dc_norm(2,nres+i)
20734         dzi=dc_norm(3,nres+i)
20735         dsci_inv=vbld_inv(i+nres)
20736 !C
20737 !C Calculate SC interaction energy.
20738 !C
20739         do iint=1,nint_gr_nucl(i)
20740 !          print *,"tu?",i,istart_nucl(i,iint),iend_nucl(i,iint)
20741           do j=istart_nucl(i,iint),iend_nucl(i,iint)
20742             ind=ind+1
20743 !            print *,"JESTEM"
20744             itypj=itype(j,2)
20745             if (itypj.eq.ntyp1_molec(2)) cycle
20746             dscj_inv=vbld_inv(j+nres)
20747             sig0ij=sigma_nucl(itypi,itypj)
20748             chi1=chi_nucl(itypi,itypj)
20749             chi2=chi_nucl(itypj,itypi)
20750             chi12=chi1*chi2
20751             chip1=chip_nucl(itypi,itypj)
20752             chip2=chip_nucl(itypj,itypi)
20753             chip12=chip1*chip2
20754 !            xj=c(1,nres+j)-xi
20755 !            yj=c(2,nres+j)-yi
20756 !            zj=c(3,nres+j)-zi
20757            xj=c(1,nres+j)
20758            yj=c(2,nres+j)
20759            zj=c(3,nres+j)
20760           xj=dmod(xj,boxxsize)
20761           if (xj.lt.0) xj=xj+boxxsize
20762           yj=dmod(yj,boxysize)
20763           if (yj.lt.0) yj=yj+boxysize
20764           zj=dmod(zj,boxzsize)
20765           if (zj.lt.0) zj=zj+boxzsize
20766       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20767       xj_safe=xj
20768       yj_safe=yj
20769       zj_safe=zj
20770       subchap=0
20771       do xshift=-1,1
20772       do yshift=-1,1
20773       do zshift=-1,1
20774           xj=xj_safe+xshift*boxxsize
20775           yj=yj_safe+yshift*boxysize
20776           zj=zj_safe+zshift*boxzsize
20777           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
20778           if(dist_temp.lt.dist_init) then
20779             dist_init=dist_temp
20780             xj_temp=xj
20781             yj_temp=yj
20782             zj_temp=zj
20783             subchap=1
20784           endif
20785        enddo
20786        enddo
20787        enddo
20788        if (subchap.eq.1) then
20789           xj=xj_temp-xi
20790           yj=yj_temp-yi
20791           zj=zj_temp-zi
20792        else
20793           xj=xj_safe-xi
20794           yj=yj_safe-yi
20795           zj=zj_safe-zi
20796        endif
20797
20798             dxj=dc_norm(1,nres+j)
20799             dyj=dc_norm(2,nres+j)
20800             dzj=dc_norm(3,nres+j)
20801             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
20802             rij=dsqrt(rrij)
20803 !C Calculate angle-dependent terms of energy and contributions to their
20804 !C derivatives.
20805             erij(1)=xj*rij
20806             erij(2)=yj*rij
20807             erij(3)=zj*rij
20808             om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
20809             om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
20810             om12=dxi*dxj+dyi*dyj+dzi*dzj
20811             call sc_angular_nucl
20812             sigsq=1.0D0/sigsq
20813             sig=sig0ij*dsqrt(sigsq)
20814             rij_shift=1.0D0/rij-sig+sig0ij
20815 !            print *,rij_shift,"rij_shift"
20816 !c            write (2,*) " rij",1.0D0/rij," sig",sig," sig0ij",sig0ij,
20817 !c     &       " rij_shift",rij_shift
20818             if (rij_shift.le.0.0D0) then
20819               evdw=1.0D20
20820               return
20821             endif
20822             sigder=-sig*sigsq
20823 !c---------------------------------------------------------------
20824             rij_shift=1.0D0/rij_shift
20825             fac=rij_shift**expon
20826             e1=fac*fac*aa_nucl(itypi,itypj)
20827             e2=fac*bb_nucl(itypi,itypj)
20828             evdwij=eps1*eps2rt*(e1+e2)
20829 !c            write (2,*) "eps1",eps1," eps2rt",eps2rt,
20830 !c     &       " e1",e1," e2",e2," evdwij",evdwij
20831             eps2der=evdwij
20832             evdwij=evdwij*eps2rt
20833             evdwsb=evdwsb+evdwij
20834             if (lprn) then
20835             sigm=dabs(aa_nucl(itypi,itypj)/bb_nucl(itypi,itypj))**(1.0D0/6.0D0)
20836             epsi=bb_nucl(itypi,itypj)**2/aa_nucl(itypi,itypj)
20837             write (iout,'(2(a3,i3,2x),17(0pf7.3))') &
20838              restyp(itypi,2),i,restyp(itypj,2),j, &
20839              epsi,sigm,chi1,chi2,chip1,chip2, &
20840              eps1,eps2rt**2,sig,sig0ij, &
20841              om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,&
20842             evdwij
20843             write (iout,*) "aa",aa_nucl(itypi,itypj)," bb",bb_nucl(itypi,itypj)
20844             endif
20845
20846             if (energy_dec) write (iout,'(a6,2i5,e15.3,a4)') &
20847                              'evdw',i,j,evdwij,"tu3"
20848
20849
20850 !C Calculate gradient components.
20851             e1=e1*eps1*eps2rt**2
20852             fac=-expon*(e1+evdwij)*rij_shift
20853             sigder=fac*sigder
20854             fac=rij*fac
20855 !c            fac=0.0d0
20856 !C Calculate the radial part of the gradient
20857             gg(1)=xj*fac
20858             gg(2)=yj*fac
20859             gg(3)=zj*fac
20860 !C Calculate angular part of the gradient.
20861             call sc_grad_nucl
20862             call eelsbij(eelij,num_conti2)
20863             if (energy_dec .and. &
20864            (j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2)) &
20865           write (istat,'(e14.5)') evdwij
20866             eelsb=eelsb+eelij
20867           enddo      ! j
20868         enddo        ! iint
20869         num_cont_hb(i)=num_conti2
20870       enddo          ! i
20871 !c      write (iout,*) "Number of loop steps in EGB:",ind
20872 !cccc      energy_dec=.false.
20873       return
20874       end subroutine esb_gb
20875 !-------------------------------------------------------------------------------
20876       subroutine eelsbij(eesij,num_conti2)
20877       use comm_locel
20878       use calc_data_nucl
20879       real(kind=8),dimension(3) :: ggg,gggp,gggm,dcosb,dcosg
20880       real(kind=8),dimension(3,3) :: erder,uryg,urzg,vryg,vrzg
20881       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
20882                     dist_temp, dist_init,rlocshield,fracinbuf
20883       integer xshift,yshift,zshift,ilist,iresshield,num_conti2
20884
20885 !c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
20886       real(kind=8) scal_el /0.5d0/
20887       integer :: iteli,itelj,kkk,kkll,m,isubchap
20888       real(kind=8) :: ael6i,rrmij,rmij,r0ij,fcont,fprimcont,ees0tmp,facfac
20889       real(kind=8) :: ees,evdw1,eel_loc,aaa,bbb,ael3i,ael63i,ael32i
20890       real(kind=8) :: dx_normj,dy_normj,dz_normj,&
20891                   r3ij,r6ij,cosa,cosb,cosg,fac,ev1,ev2,fac3,fac4,fac5,fac6,&
20892                   el1,el2,el3,el4,eesij,ees0ij,facvdw,facel,fac1,ecosa,&
20893                   ecosb,ecosg,ury,urz,vry,vrz,facr,a22der,a23der,a32der,&
20894                   a33der,eel_loc_ij,cosa4,wij,cosbg1,cosbg2,ees0pij,&
20895                   ees0pij1,ees0mij,ees0mij1,fac3p,ees0mijp,ees0pijp,&
20896                   ecosa1,ecosb1,ecosg1,ecosa2,ecosb2,ecosg2,ecosap,ecosbp,&
20897                   ecosgp,ecosam,ecosbm,ecosgm,ghalf,itypi,itypj
20898       ind=ind+1
20899       itypi=itype(i,2)
20900       itypj=itype(j,2)
20901 !      print *,i,j,itypi,itypj,istype(i),istype(j),"????"
20902       ael6i=ael6_nucl(itypi,itypj)
20903       ael3i=ael3_nucl(itypi,itypj)
20904       ael63i=ael63_nucl(itypi,itypj)
20905       ael32i=ael32_nucl(itypi,itypj)
20906 !c      write (iout,*) "eelecij",i,j,itype(i),itype(j),
20907 !c     &  ael6i,ael3i,ael63i,al32i,rij,rrij
20908       dxj=dc(1,j+nres)
20909       dyj=dc(2,j+nres)
20910       dzj=dc(3,j+nres)
20911       dx_normi=dc_norm(1,i+nres)
20912       dy_normi=dc_norm(2,i+nres)
20913       dz_normi=dc_norm(3,i+nres)
20914       dx_normj=dc_norm(1,j+nres)
20915       dy_normj=dc_norm(2,j+nres)
20916       dz_normj=dc_norm(3,j+nres)
20917 !c      xj=c(1,j)+0.5D0*dxj-xmedi
20918 !c      yj=c(2,j)+0.5D0*dyj-ymedi
20919 !c      zj=c(3,j)+0.5D0*dzj-zmedi
20920       if (ipot_nucl.ne.2) then
20921         cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
20922         cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
20923         cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
20924       else
20925         cosa=om12
20926         cosb=om1
20927         cosg=om2
20928       endif
20929       r3ij=rij*rrij
20930       r6ij=r3ij*r3ij
20931       fac=cosa-3.0D0*cosb*cosg
20932       facfac=fac*fac
20933       fac1=3.0d0*(cosb*cosb+cosg*cosg)
20934       fac3=ael6i*r6ij
20935       fac4=ael3i*r3ij
20936       fac5=ael63i*r6ij
20937       fac6=ael32i*r6ij
20938 !c      write (iout,*) "r3ij",r3ij," r6ij",r6ij," fac",fac," fac1",fac1,
20939 !c     &  " fac2",fac2," fac3",fac3," fac4",fac4," fac5",fac5," fac6",fac6
20940       el1=fac3*(4.0D0+facfac-fac1)
20941       el2=fac4*fac
20942       el3=fac5*(2.0d0-2.0d0*facfac+fac1)
20943       el4=fac6*facfac
20944       eesij=el1+el2+el3+el4
20945 !C 12/26/95 - for the evaluation of multi-body H-bonding interactions
20946       ees0ij=4.0D0+facfac-fac1
20947
20948       if (energy_dec) then
20949           if(j.eq.i+1.or.j.eq.nres-i+1.or.j.eq.nres-i.or.j.eq.nres-i+2) &
20950           write (istat,'(2a1,i4,1x,2a1,i4,4f10.5,3e12.5,$)') &
20951            sugartyp(istype(i)),restyp(itypi,2),i,sugartyp(istype(j)),&
20952            restyp(itypj,2),j,1.0d0/rij,cosa,cosb,cosg,fac*r3ij, &
20953            (4.0D0+facfac-fac1)*r6ij,(2.0d0-2.0d0*facfac+fac1)*r6ij
20954           write (iout,'(a6,2i5,e15.3)') 'ees',i,j,eesij
20955       endif
20956
20957 !C
20958 !C Calculate contributions to the Cartesian gradient.
20959 !C
20960       facel=-3.0d0*rrij*(eesij+el1+el3+el4)
20961       fac1=fac
20962 !c      erij(1)=xj*rmij
20963 !c      erij(2)=yj*rmij
20964 !c      erij(3)=zj*rmij
20965 !*
20966 !* Radial derivatives. First process both termini of the fragment (i,j)
20967 !*
20968       ggg(1)=facel*xj
20969       ggg(2)=facel*yj
20970       ggg(3)=facel*zj
20971       do k=1,3
20972         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
20973         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
20974         gelsbx(k,j)=gelsbx(k,j)+ggg(k)
20975         gelsbx(k,i)=gelsbx(k,i)-ggg(k)
20976       enddo
20977 !*
20978 !* Angular part
20979 !*
20980       ecosa=2.0D0*fac3*fac1+fac4+(-4.0d0*fac5+2.0d0*fac6)*fac1
20981       fac4=-3.0D0*fac4
20982       fac3=-6.0D0*fac3
20983       fac5= 6.0d0*fac5
20984       fac6=-6.0d0*fac6
20985       ecosb=fac3*(fac1*cosg+cosb)+cosg*fac4+(cosb+2*fac1*cosg)*fac5+&
20986        fac6*fac1*cosg
20987       ecosg=fac3*(fac1*cosb+cosg)+cosb*fac4+(cosg+2*fac1*cosb)*fac5+&
20988        fac6*fac1*cosb
20989       do k=1,3
20990         dcosb(k)=rij*(dc_norm(k,i+nres)-erij(k)*cosb)
20991         dcosg(k)=rij*(dc_norm(k,j+nres)-erij(k)*cosg)
20992       enddo
20993       do k=1,3
20994         ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
20995       enddo
20996       do k=1,3
20997         gelsbx(k,i)=gelsbx(k,i)-ggg(k) &
20998              +(ecosa*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres))&
20999              + ecosb*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21000         gelsbx(k,j)=gelsbx(k,j)+ggg(k) &
21001              +(ecosa*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21002              + ecosg*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21003         gelsbc(k,j)=gelsbc(k,j)+ggg(k)
21004         gelsbc(k,i)=gelsbc(k,i)-ggg(k)
21005       enddo
21006 !      IF ( (wcorr_nucl.gt.0.0d0.or.wcorr3_nucl.gt.0.0d0) .and.
21007        IF ( j.gt.i+1 .and.&
21008           num_conti.le.maxconts) THEN
21009 !C
21010 !C Calculate the contact function. The ith column of the array JCONT will
21011 !C contain the numbers of atoms that make contacts with the atom I (of numbers
21012 !C greater than I). The arrays FACONT and GACONT will contain the values of
21013 !C the contact function and its derivative.
21014         r0ij=2.20D0*sigma(itypi,itypj)
21015 !c        write (2,*) "ij",i,j," rij",1.0d0/rij," r0ij",r0ij
21016         call gcont(rij,r0ij,1.0D0,0.2d0/r0ij,fcont,fprimcont)
21017 !c        write (2,*) "fcont",fcont
21018         if (fcont.gt.0.0D0) then
21019           num_conti=num_conti+1
21020           num_conti2=num_conti2+1
21021
21022           if (num_conti.gt.maxconts) then
21023             write (iout,*) 'WARNING - max. # of contacts exceeded;',&
21024                           ' will skip next contacts for this conf.'
21025           else
21026             jcont_hb(num_conti,i)=j
21027 !c            write (iout,*) "num_conti",num_conti,
21028 !c     &        " jcont_hb",jcont_hb(num_conti,i)
21029 !C Calculate contact energies
21030             cosa4=4.0D0*cosa
21031             wij=cosa-3.0D0*cosb*cosg
21032             cosbg1=cosb+cosg
21033             cosbg2=cosb-cosg
21034             fac3=dsqrt(-ael6i)*r3ij
21035 !c            write (2,*) "ael6i",ael6i," r3ij",r3ij," fac3",fac3
21036             ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
21037             if (ees0tmp.gt.0) then
21038               ees0pij=dsqrt(ees0tmp)
21039             else
21040               ees0pij=0
21041             endif
21042             ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
21043             if (ees0tmp.gt.0) then
21044               ees0mij=dsqrt(ees0tmp)
21045             else
21046               ees0mij=0
21047             endif
21048             ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
21049             ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
21050 !c            write (iout,*) "i",i," j",j,
21051 !c     &         " ees0m",ees0m(num_conti,i)," ees0p",ees0p(num_conti,i)
21052             ees0pij1=fac3/ees0pij
21053             ees0mij1=fac3/ees0mij
21054             fac3p=-3.0D0*fac3*rrij
21055             ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
21056             ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
21057             ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
21058             ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
21059             ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
21060             ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
21061             ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
21062             ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
21063             ecosap=ecosa1+ecosa2
21064             ecosbp=ecosb1+ecosb2
21065             ecosgp=ecosg1+ecosg2
21066             ecosam=ecosa1-ecosa2
21067             ecosbm=ecosb1-ecosb2
21068             ecosgm=ecosg1-ecosg2
21069 !C End diagnostics
21070             facont_hb(num_conti,i)=fcont
21071             fprimcont=fprimcont/rij
21072             do k=1,3
21073               gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
21074               gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
21075             enddo
21076             gggp(1)=gggp(1)+ees0pijp*xj
21077             gggp(2)=gggp(2)+ees0pijp*yj
21078             gggp(3)=gggp(3)+ees0pijp*zj
21079             gggm(1)=gggm(1)+ees0mijp*xj
21080             gggm(2)=gggm(2)+ees0mijp*yj
21081             gggm(3)=gggm(3)+ees0mijp*zj
21082 !C Derivatives due to the contact function
21083             gacont_hbr(1,num_conti,i)=fprimcont*xj
21084             gacont_hbr(2,num_conti,i)=fprimcont*yj
21085             gacont_hbr(3,num_conti,i)=fprimcont*zj
21086             do k=1,3
21087 !c
21088 !c Gradient of the correlation terms
21089 !c
21090               gacontp_hb1(k,num_conti,i)= &
21091              (ecosap*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21092             + ecosbp*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21093               gacontp_hb2(k,num_conti,i)= &
21094              (ecosap*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres)) &
21095             + ecosgp*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21096               gacontp_hb3(k,num_conti,i)=gggp(k)
21097               gacontm_hb1(k,num_conti,i)= &
21098              (ecosam*(dc_norm(k,j+nres)-cosa*dc_norm(k,i+nres)) &
21099             + ecosbm*(erij(k)-cosb*dc_norm(k,i+nres)))*vbld_inv(i+nres)
21100               gacontm_hb2(k,num_conti,i)= &
21101              (ecosam*(dc_norm(k,i+nres)-cosa*dc_norm(k,j+nres))&
21102             + ecosgm*(erij(k)-cosg*dc_norm(k,j+nres)))*vbld_inv(j+nres)
21103               gacontm_hb3(k,num_conti,i)=gggm(k)
21104             enddo
21105           endif
21106         endif
21107       ENDIF
21108       return
21109       end subroutine eelsbij
21110 !------------------------------------------------------------------
21111       subroutine sc_grad_nucl
21112       use comm_locel
21113       use calc_data_nucl
21114       real(kind=8),dimension(3) :: dcosom1,dcosom2
21115       eom1=eps2der*eps2rt_om1+sigder*sigsq_om1
21116       eom2=eps2der*eps2rt_om2+sigder*sigsq_om2
21117       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12+sigder*sigsq_om12
21118       do k=1,3
21119         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
21120         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
21121       enddo
21122       do k=1,3
21123         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
21124       enddo
21125       do k=1,3
21126         gvdwsbx(k,i)=gvdwsbx(k,i)-gg(k) &
21127                  +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
21128                  +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
21129         gvdwsbx(k,j)=gvdwsbx(k,j)+gg(k) &
21130                  +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
21131                  +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
21132       enddo
21133 !C
21134 !C Calculate the components of the gradient in DC and X
21135 !C
21136       do l=1,3
21137         gvdwsbc(l,i)=gvdwsbc(l,i)-gg(l)
21138         gvdwsbc(l,j)=gvdwsbc(l,j)+gg(l)
21139       enddo
21140       return
21141       end subroutine sc_grad_nucl
21142 !-----------------------------------------------------------------------
21143       subroutine esb(esbloc)
21144 !C Calculate the local energy of a side chain and its derivatives in the
21145 !C corresponding virtual-bond valence angles THETA and the spherical angles
21146 !C ALPHA and OMEGA derived from AM1 all-atom calculations.
21147 !C added by Urszula Kozlowska. 07/11/2007
21148 !C
21149       real(kind=8),dimension(3):: x_prime,y_prime,z_prime
21150       real(kind=8),dimension(9):: x
21151      real(kind=8) :: sumene,dsc_i,dp2_i,xx,yy,zz,sumene1, &
21152       sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,&
21153       de_dxx,de_dyy,de_dzz,de_dt,s1_t,s1_6_t,s2_t,s2_6_t
21154       real(kind=8),dimension(3):: dXX_Ci1,dYY_Ci1,dZZ_Ci1,dXX_Ci,&
21155        dYY_Ci,dZZ_Ci,dXX_XYZ,dYY_XYZ,dZZ_XYZ,dt_dCi,dt_dCi1
21156        real(kind=8) :: esbloc,delta,cosfac2,cosfac,sinfac2,sinfac,de_dtt,&
21157        cossc,cossc1,cosfac2xx,sinfac2yy,pom1,pom
21158        integer::it,nlobit,i,j,k
21159 !      common /sccalc/ time11,time12,time112,theti,it,nlobit
21160       delta=0.02d0*pi
21161       esbloc=0.0D0
21162       do i=loc_start_nucl,loc_end_nucl
21163         if (itype(i,2).eq.ntyp1_molec(2)) cycle
21164         costtab(i+1) =dcos(theta(i+1))
21165         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
21166         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
21167         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
21168         cosfac2=0.5d0/(1.0d0+costtab(i+1))
21169         cosfac=dsqrt(cosfac2)
21170         sinfac2=0.5d0/(1.0d0-costtab(i+1))
21171         sinfac=dsqrt(sinfac2)
21172         it=itype(i,2)
21173         if (it.eq.10) goto 1
21174
21175 !c
21176 !C  Compute the axes of tghe local cartesian coordinates system; store in
21177 !c   x_prime, y_prime and z_prime
21178 !c
21179         do j=1,3
21180           x_prime(j) = 0.00
21181           y_prime(j) = 0.00
21182           z_prime(j) = 0.00
21183         enddo
21184 !C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
21185 !C     &   dc_norm(3,i+nres)
21186         do j = 1,3
21187           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
21188           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
21189         enddo
21190         do j = 1,3
21191           z_prime(j) = -uz(j,i-1)
21192 !           z_prime(j)=0.0
21193         enddo
21194
21195         xx=0.0d0
21196         yy=0.0d0
21197         zz=0.0d0
21198         do j = 1,3
21199           xx = xx + x_prime(j)*dc_norm(j,i+nres)
21200           yy = yy + y_prime(j)*dc_norm(j,i+nres)
21201           zz = zz + z_prime(j)*dc_norm(j,i+nres)
21202         enddo
21203
21204         xxtab(i)=xx
21205         yytab(i)=yy
21206         zztab(i)=zz
21207          it=itype(i,2)
21208         do j = 1,9
21209           x(j) = sc_parmin_nucl(j,it)
21210         enddo
21211 #ifdef CHECK_COORD
21212 !Cc diagnostics - remove later
21213         xx1 = dcos(alph(2))
21214         yy1 = dsin(alph(2))*dcos(omeg(2))
21215         zz1 = -dsin(alph(2))*dsin(omeg(2))
21216         write(2,'(3f8.1,3f9.3,1x,3f9.3)') &
21217          alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,&
21218          xx1,yy1,zz1
21219 !C,"  --- ", xx_w,yy_w,zz_w
21220 !c end diagnostics
21221 #endif
21222         sumene = enesc_nucl(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21223         esbloc = esbloc + sumene
21224         sumene2= enesc_nucl(x,xx,yy,0.0d0,cost2tab(i+1),sint2tab(i+1))
21225 !        print *,"enecomp",sumene,sumene2
21226 !        if (energy_dec) write(iout,*) "i",i," esbloc",sumene,esbloc,xx,yy,zz
21227 !        if (energy_dec) write(iout,*) "x",(x(k),k=1,9)
21228 #ifdef DEBUG
21229         write (2,*) "x",(x(k),k=1,9)
21230 !C
21231 !C This section to check the numerical derivatives of the energy of ith side
21232 !C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
21233 !C #define DEBUG in the code to turn it on.
21234 !C
21235         write (2,*) "sumene               =",sumene
21236         aincr=1.0d-7
21237         xxsave=xx
21238         xx=xx+aincr
21239         write (2,*) xx,yy,zz
21240         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21241         de_dxx_num=(sumenep-sumene)/aincr
21242         xx=xxsave
21243         write (2,*) "xx+ sumene from enesc=",sumenep,sumene
21244         yysave=yy
21245         yy=yy+aincr
21246         write (2,*) xx,yy,zz
21247         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21248         de_dyy_num=(sumenep-sumene)/aincr
21249         yy=yysave
21250         write (2,*) "yy+ sumene from enesc=",sumenep,sumene
21251         zzsave=zz
21252         zz=zz+aincr
21253         write (2,*) xx,yy,zz
21254         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21255         de_dzz_num=(sumenep-sumene)/aincr
21256         zz=zzsave
21257         write (2,*) "zz+ sumene from enesc=",sumenep,sumene
21258         costsave=cost2tab(i+1)
21259         sintsave=sint2tab(i+1)
21260         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
21261         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
21262         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
21263         de_dt_num=(sumenep-sumene)/aincr
21264         write (2,*) " t+ sumene from enesc=",sumenep,sumene
21265         cost2tab(i+1)=costsave
21266         sint2tab(i+1)=sintsave
21267 !C End of diagnostics section.
21268 #endif
21269 !C
21270 !C Compute the gradient of esc
21271 !C
21272         de_dxx=x(1)+2*x(4)*xx+x(7)*zz+x(8)*yy
21273         de_dyy=x(2)+2*x(5)*yy+x(8)*xx+x(9)*zz
21274         de_dzz=x(3)+2*x(6)*zz+x(7)*xx+x(9)*yy
21275         de_dtt=0.0d0
21276 #ifdef DEBUG
21277         write (2,*) "x",(x(k),k=1,9)
21278         write (2,*) "xx",xx," yy",yy," zz",zz
21279         write (2,*) "de_xx   ",de_xx," de_yy   ",de_yy,&
21280           " de_zz   ",de_zz," de_tt   ",de_tt
21281         write (2,*) "de_xx_num",de_dxx_num," de_yy_num",de_dyy_num,&
21282           " de_zz_num",de_dzz_num," de_dt_num",de_dt_num
21283 #endif
21284 !C
21285        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
21286        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
21287        cosfac2xx=cosfac2*xx
21288        sinfac2yy=sinfac2*yy
21289        do k = 1,3
21290          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*&
21291            vbld_inv(i+1)
21292          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*&
21293            vbld_inv(i)
21294          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
21295          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
21296 !c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
21297 !c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
21298 !c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
21299 !c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
21300          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
21301          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
21302          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
21303          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
21304          dZZ_Ci1(k)=0.0d0
21305          dZZ_Ci(k)=0.0d0
21306          do j=1,3
21307            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)*dC_norm(j,i+nres)
21308            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)*dC_norm(j,i+nres)
21309          enddo
21310
21311          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
21312          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
21313          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
21314 !c
21315          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
21316          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
21317        enddo
21318
21319        do k=1,3
21320          dXX_Ctab(k,i)=dXX_Ci(k)
21321          dXX_C1tab(k,i)=dXX_Ci1(k)
21322          dYY_Ctab(k,i)=dYY_Ci(k)
21323          dYY_C1tab(k,i)=dYY_Ci1(k)
21324          dZZ_Ctab(k,i)=dZZ_Ci(k)
21325          dZZ_C1tab(k,i)=dZZ_Ci1(k)
21326          dXX_XYZtab(k,i)=dXX_XYZ(k)
21327          dYY_XYZtab(k,i)=dYY_XYZ(k)
21328          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
21329        enddo
21330        do k = 1,3
21331 !c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
21332 !c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
21333 !c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
21334 !c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
21335 !c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
21336 !c     &    dt_dci(k)
21337 !c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
21338 !c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
21339          gsbloc(k,i-1)=gsbloc(k,i-1)+(de_dxx*dxx_ci1(k) &
21340          +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k))
21341          gsbloc(k,i)=gsbloc(k,i)+(de_dxx*dxx_Ci(k) &
21342          +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k))
21343          gsblocx(k,i)=                 de_dxx*dxx_XYZ(k)&
21344          +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
21345 !         print *,i,de_dxx*dxx_ci1(k)+de_dyy*dyy_ci1(k),de_dzz*dzz_ci1(k)*2
21346        enddo
21347 !c       write(iout,*) "ENERGY GRAD = ", (gsbloc(k,i-1),k=1,3),
21348 !c     &  (gsbloc(k,i),k=1,3),(gsblocx(k,i),k=1,3)
21349
21350 !C to check gradient call subroutine check_grad
21351
21352     1 continue
21353       enddo
21354       return
21355       end subroutine esb
21356 !=-------------------------------------------------------
21357       real(kind=8) function enesc_nucl(x,xx,yy,zz,cost2,sint2)
21358 !      implicit none
21359       real(kind=8),dimension(9):: x(9)
21360        real(kind=8) :: xx,yy,zz,cost2,sint2,sumene1,sumene2, &
21361       sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
21362       integer i
21363 !c      write (2,*) "enesc"
21364 !c      write (2,*) "x",(x(i),i=1,9)
21365 !c      write(2,*)"xx",xx," yy",yy," zz",zz," cost2",cost2," sint2",sint2
21366       sumene=x(1)*xx+x(2)*yy+x(3)*zz+x(4)*xx**2 &
21367         + x(5)*yy**2+x(6)*zz**2+x(7)*xx*zz+x(8)*xx*yy &
21368         + x(9)*yy*zz
21369       enesc_nucl=sumene
21370       return
21371       end function enesc_nucl
21372 !-----------------------------------------------------------------------------
21373       subroutine multibody_hb_nucl(ecorr,ecorr3,n_corr,n_corr1)
21374 #ifdef MPI
21375       include 'mpif.h'
21376       integer,parameter :: max_cont=2000
21377       integer,parameter:: max_dim=2*(8*3+6)
21378       integer, parameter :: msglen1=max_cont*max_dim
21379       integer,parameter :: msglen2=2*msglen1
21380       integer source,CorrelType,CorrelID,Error
21381       real(kind=8) :: buffer(max_cont,max_dim)
21382       integer status(MPI_STATUS_SIZE)
21383       integer :: ierror,nbytes
21384 #endif
21385       real(kind=8),dimension(3):: gx(3),gx1(3)
21386       real(kind=8) :: time00
21387       logical lprn,ldone
21388       integer i,j,i1,j1,jj,kk,num_conti,num_conti1,nn
21389       real(kind=8) ecorr,ecorr3
21390       integer :: n_corr,n_corr1,mm,msglen
21391 !C Set lprn=.true. for debugging
21392       lprn=.false.
21393       n_corr=0
21394       n_corr1=0
21395 #ifdef MPI
21396       if(.not.allocated(zapas2)) allocate(zapas2(3,maxconts,nres,8))
21397
21398       if (nfgtasks.le.1) goto 30
21399       if (lprn) then
21400         write (iout,'(a)') 'Contact function values:'
21401         do i=nnt,nct-1
21402           write (iout,'(2i3,50(1x,i2,f5.2))')  &
21403          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21404          j=1,num_cont_hb(i))
21405         enddo
21406       endif
21407 !C Caution! Following code assumes that electrostatic interactions concerning
21408 !C a given atom are split among at most two processors!
21409       CorrelType=477
21410       CorrelID=fg_rank+1
21411       ldone=.false.
21412       do i=1,max_cont
21413         do j=1,max_dim
21414           buffer(i,j)=0.0D0
21415         enddo
21416       enddo
21417       mm=mod(fg_rank,2)
21418 !c      write (*,*) 'MyRank',MyRank,' mm',mm
21419       if (mm) 20,20,10
21420    10 continue
21421 !c      write (*,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
21422       if (fg_rank.gt.0) then
21423 !C Send correlation contributions to the preceding processor
21424         msglen=msglen1
21425         nn=num_cont_hb(iatel_s_nucl)
21426         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
21427 !c        write (*,*) 'The BUFFER array:'
21428 !c        do i=1,nn
21429 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,30)
21430 !c        enddo
21431         if (ielstart_nucl(iatel_s_nucl).gt.iatel_s_nucl+ispp) then
21432           msglen=msglen2
21433           call pack_buffer(max_cont,max_dim,iatel_s+1,30,buffer)
21434 !C Clear the contacts of the atom passed to the neighboring processor
21435         nn=num_cont_hb(iatel_s_nucl+1)
21436 !c        do i=1,nn
21437 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j+30),j=1,30)
21438 !c        enddo
21439             num_cont_hb(iatel_s_nucl)=0
21440         endif
21441 !cd      write (iout,*) 'Processor ',fg_rank,MyRank,
21442 !cd   & ' is sending correlation contribution to processor',fg_rank-1,
21443 !cd   & ' msglen=',msglen
21444 !c        write (*,*) 'Processor ',fg_rank,MyRank,
21445 !c     & ' is sending correlation contribution to processor',fg_rank-1,
21446 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21447         time00=MPI_Wtime()
21448         call MPI_Send(buffer,msglen,MPI_DOUBLE_PRECISION,fg_rank-1, &
21449          CorrelType,FG_COMM,IERROR)
21450         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21451 !cd      write (iout,*) 'Processor ',fg_rank,
21452 !cd   & ' has sent correlation contribution to processor',fg_rank-1,
21453 !cd   & ' msglen=',msglen,' CorrelID=',CorrelID
21454 !c        write (*,*) 'Processor ',fg_rank,
21455 !c     & ' has sent correlation contribution to processor',fg_rank-1,
21456 !c     & ' msglen=',msglen,' CorrelID=',CorrelID
21457 !c        msglen=msglen1
21458       endif ! (fg_rank.gt.0)
21459       if (ldone) goto 30
21460       ldone=.true.
21461    20 continue
21462 !c      write (*,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
21463       if (fg_rank.lt.nfgtasks-1) then
21464 !C Receive correlation contributions from the next processor
21465         msglen=msglen1
21466         if (ielend_nucl(iatel_e_nucl).lt.nct_molec(2)-1) msglen=msglen2
21467 !cd      write (iout,*) 'Processor',fg_rank,
21468 !cd   & ' is receiving correlation contribution from processor',fg_rank+1,
21469 !cd   & ' msglen=',msglen,' CorrelType=',CorrelType
21470 !c        write (*,*) 'Processor',fg_rank,
21471 !c     &' is receiving correlation contribution from processor',fg_rank+1,
21472 !c     & ' msglen=',msglen,' CorrelType=',CorrelType
21473         time00=MPI_Wtime()
21474         nbytes=-1
21475         do while (nbytes.le.0)
21476           call MPI_Probe(fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21477           call MPI_Get_count(status,MPI_DOUBLE_PRECISION,nbytes,IERROR)
21478         enddo
21479 !c        print *,'Processor',myrank,' msglen',msglen,' nbytes',nbytes
21480         call MPI_Recv(buffer,nbytes,MPI_DOUBLE_PRECISION, &
21481          fg_rank+1,CorrelType,FG_COMM,status,IERROR)
21482         time_sendrecv=time_sendrecv+MPI_Wtime()-time00
21483 !c        write (*,*) 'Processor',fg_rank,
21484 !c     &' has received correlation contribution from processor',fg_rank+1,
21485 !c     & ' msglen=',msglen,' nbytes=',nbytes
21486 !c        write (*,*) 'The received BUFFER array:'
21487 !c        do i=1,max_cont
21488 !c          write (*,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,60)
21489 !c        enddo
21490         if (msglen.eq.msglen1) then
21491           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,0,buffer)
21492         else if (msglen.eq.msglen2)  then
21493           call unpack_buffer(max_cont,max_dim,iatel_e_nucl,0,buffer)
21494           call unpack_buffer(max_cont,max_dim,iatel_e_nucl+1,30,buffer)
21495         else
21496           write (iout,*) &
21497       'ERROR!!!! message length changed while processing correlations.'
21498           write (*,*) &
21499       'ERROR!!!! message length changed while processing correlations.'
21500           call MPI_Abort(MPI_COMM_WORLD,Error,IERROR)
21501         endif ! msglen.eq.msglen1
21502       endif ! fg_rank.lt.nfgtasks-1
21503       if (ldone) goto 30
21504       ldone=.true.
21505       goto 10
21506    30 continue
21507 #endif
21508       if (lprn) then
21509         write (iout,'(a)') 'Contact function values:'
21510         do i=nnt_molec(2),nct_molec(2)-1
21511           write (iout,'(2i3,50(1x,i2,f5.2))') &
21512          i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i), &
21513          j=1,num_cont_hb(i))
21514         enddo
21515       endif
21516       ecorr=0.0D0
21517       ecorr3=0.0d0
21518 !C Remove the loop below after debugging !!!
21519 !      do i=nnt_molec(2),nct_molec(2)
21520 !        do j=1,3
21521 !          gradcorr_nucl(j,i)=0.0D0
21522 !          gradxorr_nucl(j,i)=0.0D0
21523 !          gradcorr3_nucl(j,i)=0.0D0
21524 !          gradxorr3_nucl(j,i)=0.0D0
21525 !        enddo
21526 !      enddo
21527 !      print *,"iatsc_s_nucl,iatsc_e_nucl",iatsc_s_nucl,iatsc_e_nucl
21528 !C Calculate the local-electrostatic correlation terms
21529       do i=iatsc_s_nucl,iatsc_e_nucl
21530         i1=i+1
21531         num_conti=num_cont_hb(i)
21532         num_conti1=num_cont_hb(i+1)
21533 !        print *,i,num_conti,num_conti1
21534         do jj=1,num_conti
21535           j=jcont_hb(jj,i)
21536           do kk=1,num_conti1
21537             j1=jcont_hb(kk,i1)
21538 !c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
21539 !c     &         ' jj=',jj,' kk=',kk
21540             if (j1.eq.j+1 .or. j1.eq.j-1) then
21541 !C
21542 !C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
21543 !C The system gains extra energy.
21544 !C Tentative expression & coefficients; assumed d(stacking)=4.5 A,
21545 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21546 !C Need to implement full formulas 34 and 35 from Liwo et al., 1998.
21547 !C
21548               ecorr=ecorr+ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21549               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)') &
21550                  'ecorrh',i,j,ehbcorr_nucl(i,j,i+1,j1,jj,kk,0.528D0,0.132D0)
21551               n_corr=n_corr+1
21552             else if (j1.eq.j) then
21553 !C
21554 !C Contacts I-J and I-(J+1) occur simultaneously.
21555 !C The system loses extra energy.
21556 !C Tentative expression & c?oefficients; assumed d(stacking)=4.5 A,
21557 !C parallel dipoles of stacknig bases and sin(mui)sin(muj)/eps/d^3=0.7
21558 !C Need to implement full formulas 32 from Liwo et al., 1998.
21559 !C
21560 !c              write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21561 !c     &         ' jj=',jj,' kk=',kk
21562               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i+1,j,jj,kk,0.310D0,-0.155D0)
21563             endif
21564           enddo ! kk
21565           do kk=1,num_conti
21566             j1=jcont_hb(kk,i)
21567 !c            write (iout,*) 'ecorr3: i=',i,' j=',j,' i1=',i1,' j1=',j1,
21568 !c     &         ' jj=',jj,' kk=',kk
21569             if (j1.eq.j+1) then
21570 !C Contacts I-J and (I+1)-J occur simultaneously.
21571 !C The system loses extra energy.
21572               ecorr3=ecorr3+ehbcorr3_nucl(i,j,i,j+1,jj,kk,0.310D0,-0.155D0)
21573             endif ! j1==j+1
21574           enddo ! kk
21575         enddo ! jj
21576       enddo ! i
21577       return
21578       end subroutine multibody_hb_nucl
21579 !-----------------------------------------------------------
21580       real(kind=8) function ehbcorr_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21581 !      implicit real*8 (a-h,o-z)
21582 !      include 'DIMENSIONS'
21583 !      include 'COMMON.IOUNITS'
21584 !      include 'COMMON.DERIV'
21585 !      include 'COMMON.INTERACT'
21586 !      include 'COMMON.CONTACTS'
21587       real(kind=8),dimension(3) :: gx,gx1
21588       logical :: lprn
21589 !el local variables
21590       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21591       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21592                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21593                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21594                    rlocshield
21595
21596       lprn=.false.
21597       eij=facont_hb(jj,i)
21598       ekl=facont_hb(kk,k)
21599       ees0pij=ees0p(jj,i)
21600       ees0pkl=ees0p(kk,k)
21601       ees0mij=ees0m(jj,i)
21602       ees0mkl=ees0m(kk,k)
21603       ekont=eij*ekl
21604       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21605 !      print *,"ehbcorr_nucl",ekont,ees
21606 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21607 !C Following 4 lines for diagnostics.
21608 !cd    ees0pkl=0.0D0
21609 !cd    ees0pij=1.0D0
21610 !cd    ees0mkl=0.0D0
21611 !cd    ees0mij=1.0D0
21612 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21613 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21614 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21615 !C Calculate the multi-body contribution to energy.
21616 !      ecorr_nucl=ecorr_nucl+ekont*ees
21617 !C Calculate multi-body contributions to the gradient.
21618       coeffpees0pij=coeffp*ees0pij
21619       coeffmees0mij=coeffm*ees0mij
21620       coeffpees0pkl=coeffp*ees0pkl
21621       coeffmees0mkl=coeffm*ees0mkl
21622       do ll=1,3
21623         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i) &
21624        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21625        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21626         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j) &
21627         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+&
21628         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21629         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k) &
21630         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+&
21631         coeffmees0mij*gacontm_hb1(ll,kk,k))
21632         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l) &
21633         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21634         coeffmees0mij*gacontm_hb2(ll,kk,k))
21635         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21636           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21637           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21638         gradcorr_nucl(ll,j)=gradcorr_nucl(ll,j)+gradlongij
21639         gradcorr_nucl(ll,i)=gradcorr_nucl(ll,i)-gradlongij
21640         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21641           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21642           coeffmees0mij*gacontm_hb3(ll,kk,k))
21643         gradcorr_nucl(ll,l)=gradcorr_nucl(ll,l)+gradlongkl
21644         gradcorr_nucl(ll,k)=gradcorr_nucl(ll,k)-gradlongkl
21645         gradxorr_nucl(ll,i)=gradxorr_nucl(ll,i)-gradlongij
21646         gradxorr_nucl(ll,j)=gradxorr_nucl(ll,j)+gradlongij
21647         gradxorr_nucl(ll,k)=gradxorr_nucl(ll,k)-gradlongkl
21648         gradxorr_nucl(ll,l)=gradxorr_nucl(ll,l)+gradlongkl
21649       enddo
21650       ehbcorr_nucl=ekont*ees
21651       return
21652       end function ehbcorr_nucl
21653 !-------------------------------------------------------------------------
21654
21655      real(kind=8) function ehbcorr3_nucl(i,j,k,l,jj,kk,coeffp,coeffm)
21656 !      implicit real*8 (a-h,o-z)
21657 !      include 'DIMENSIONS'
21658 !      include 'COMMON.IOUNITS'
21659 !      include 'COMMON.DERIV'
21660 !      include 'COMMON.INTERACT'
21661 !      include 'COMMON.CONTACTS'
21662       real(kind=8),dimension(3) :: gx,gx1
21663       logical :: lprn
21664 !el local variables
21665       integer :: i,j,k,l,jj,kk,ll,ilist,m, iresshield
21666       real(kind=8) :: coeffp,coeffm,eij,ekl,ees0pij,ees0pkl,ees0mij,&
21667                    ees0mkl,ees,coeffpees0pij,coeffmees0mij,&
21668                    coeffpees0pkl,coeffmees0mkl,gradlongij,gradlongkl, &
21669                    rlocshield
21670
21671       lprn=.false.
21672       eij=facont_hb(jj,i)
21673       ekl=facont_hb(kk,k)
21674       ees0pij=ees0p(jj,i)
21675       ees0pkl=ees0p(kk,k)
21676       ees0mij=ees0m(jj,i)
21677       ees0mkl=ees0m(kk,k)
21678       ekont=eij*ekl
21679       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
21680 !cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
21681 !C Following 4 lines for diagnostics.
21682 !cd    ees0pkl=0.0D0
21683 !cd    ees0pij=1.0D0
21684 !cd    ees0mkl=0.0D0
21685 !cd    ees0mij=1.0D0
21686 !cd      write (iout,*)'Contacts have occurred for nucleic bases',
21687 !cd     &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
21688 !cd     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
21689 !C Calculate the multi-body contribution to energy.
21690 !      ecorr=ecorr+ekont*ees
21691 !C Calculate multi-body contributions to the gradient.
21692       coeffpees0pij=coeffp*ees0pij
21693       coeffmees0mij=coeffm*ees0mij
21694       coeffpees0pkl=coeffp*ees0pkl
21695       coeffmees0mkl=coeffm*ees0mkl
21696       do ll=1,3
21697         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i) &
21698        -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+&
21699        coeffmees0mkl*gacontm_hb1(ll,jj,i))
21700         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j) &
21701         -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+ &
21702         coeffmees0mkl*gacontm_hb2(ll,jj,i))
21703         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k) &
21704         -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+ &
21705         coeffmees0mij*gacontm_hb1(ll,kk,k))
21706         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l) &
21707         -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+ &
21708         coeffmees0mij*gacontm_hb2(ll,kk,k))
21709         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)- &
21710           ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+ &
21711           coeffmees0mkl*gacontm_hb3(ll,jj,i))
21712         gradcorr3_nucl(ll,j)=gradcorr3_nucl(ll,j)+gradlongij
21713         gradcorr3_nucl(ll,i)=gradcorr3_nucl(ll,i)-gradlongij
21714         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)- &
21715           ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+ &
21716           coeffmees0mij*gacontm_hb3(ll,kk,k))
21717         gradcorr3_nucl(ll,l)=gradcorr3_nucl(ll,l)+gradlongkl
21718         gradcorr3_nucl(ll,k)=gradcorr3_nucl(ll,k)-gradlongkl
21719         gradxorr3_nucl(ll,i)=gradxorr3_nucl(ll,i)-gradlongij
21720         gradxorr3_nucl(ll,j)=gradxorr3_nucl(ll,j)+gradlongij
21721         gradxorr3_nucl(ll,k)=gradxorr3_nucl(ll,k)-gradlongkl
21722         gradxorr3_nucl(ll,l)=gradxorr3_nucl(ll,l)+gradlongkl
21723       enddo
21724       ehbcorr3_nucl=ekont*ees
21725       return
21726       end function ehbcorr3_nucl
21727 #ifdef MPI
21728       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
21729       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21730       real(kind=8):: buffer(dimen1,dimen2)
21731       num_kont=num_cont_hb(atom)
21732       do i=1,num_kont
21733         do k=1,8
21734           do j=1,3
21735             buffer(i,indx+(k-1)*3+j)=zapas2(j,i,atom,k)
21736           enddo ! j
21737         enddo ! k
21738         buffer(i,indx+25)=facont_hb(i,atom)
21739         buffer(i,indx+26)=ees0p(i,atom)
21740         buffer(i,indx+27)=ees0m(i,atom)
21741         buffer(i,indx+28)=d_cont(i,atom)
21742         buffer(i,indx+29)=dfloat(jcont_hb(i,atom))
21743       enddo ! i
21744       buffer(1,indx+30)=dfloat(num_kont)
21745       return
21746       end subroutine pack_buffer
21747 !c------------------------------------------------------------------------------
21748       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
21749       integer dimen1,dimen2,atom,indx,numcont,i,ii,k,j,num_kont,num_kont_old
21750       real(kind=8):: buffer(dimen1,dimen2)
21751 !      double precision zapas
21752 !      common /contacts_hb/ zapas(3,maxconts,maxres,8),
21753 !     &   facont_hb(maxconts,maxres),ees0p(maxconts,maxres),
21754 !     &         ees0m(maxconts,maxres),d_cont(maxconts,maxres),
21755 !     &         num_cont_hb(maxres),jcont_hb(maxconts,maxres)
21756       num_kont=buffer(1,indx+30)
21757       num_kont_old=num_cont_hb(atom)
21758       num_cont_hb(atom)=num_kont+num_kont_old
21759       do i=1,num_kont
21760         ii=i+num_kont_old
21761         do k=1,8
21762           do j=1,3
21763             zapas2(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
21764           enddo ! j
21765         enddo ! k
21766         facont_hb(ii,atom)=buffer(i,indx+25)
21767         ees0p(ii,atom)=buffer(i,indx+26)
21768         ees0m(ii,atom)=buffer(i,indx+27)
21769         d_cont(i,atom)=buffer(i,indx+28)
21770         jcont_hb(ii,atom)=buffer(i,indx+29)
21771       enddo ! i
21772       return
21773       end subroutine unpack_buffer
21774 !c------------------------------------------------------------------------------
21775 #endif
21776       subroutine ecatcat(ecationcation)
21777         integer :: i,j,itmp,xshift,yshift,zshift,subchap,k
21778         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21779         r7,r4,ecationcation,k0,rcal
21780         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21781         dist_init,dist_temp,Evan1cat,Evan2cat,Eeleccat
21782         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21783         gg,r
21784
21785         ecationcation=0.0d0
21786         if (nres_molec(5).eq.0) return
21787         rcat0=3.472
21788         epscalc=0.05
21789         r06 = rcat0**6
21790         r012 = r06**2
21791         k0 = 332.0*(2.0*2.0)/80.0
21792         itmp=0
21793
21794         do i=1,4
21795         itmp=itmp+nres_molec(i)
21796         enddo
21797 !        write(iout,*) "itmp",itmp
21798         do i=itmp+1,itmp+nres_molec(5)-1
21799
21800         xi=c(1,i)
21801         yi=c(2,i)
21802         zi=c(3,i)
21803
21804           xi=mod(xi,boxxsize)
21805           if (xi.lt.0) xi=xi+boxxsize
21806           yi=mod(yi,boxysize)
21807           if (yi.lt.0) yi=yi+boxysize
21808           zi=mod(zi,boxzsize)
21809           if (zi.lt.0) zi=zi+boxzsize
21810
21811           do j=i+1,itmp+nres_molec(5)
21812 !           print *,i,j,'catcat'
21813            xj=c(1,j)
21814            yj=c(2,j)
21815            zj=c(3,j)
21816           xj=dmod(xj,boxxsize)
21817           if (xj.lt.0) xj=xj+boxxsize
21818           yj=dmod(yj,boxysize)
21819           if (yj.lt.0) yj=yj+boxysize
21820           zj=dmod(zj,boxzsize)
21821           if (zj.lt.0) zj=zj+boxzsize
21822 !          write(iout,*) c(1,i),xi,xj,"xy",boxxsize
21823       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21824       xj_safe=xj
21825       yj_safe=yj
21826       zj_safe=zj
21827       subchap=0
21828       do xshift=-1,1
21829       do yshift=-1,1
21830       do zshift=-1,1
21831           xj=xj_safe+xshift*boxxsize
21832           yj=yj_safe+yshift*boxysize
21833           zj=zj_safe+zshift*boxzsize
21834           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21835           if(dist_temp.lt.dist_init) then
21836             dist_init=dist_temp
21837             xj_temp=xj
21838             yj_temp=yj
21839             zj_temp=zj
21840             subchap=1
21841           endif
21842        enddo
21843        enddo
21844        enddo
21845        if (subchap.eq.1) then
21846           xj=xj_temp-xi
21847           yj=yj_temp-yi
21848           zj=zj_temp-zi
21849        else
21850           xj=xj_safe-xi
21851           yj=yj_safe-yi
21852           zj=zj_safe-zi
21853        endif
21854        rcal =xj**2+yj**2+zj**2
21855         ract=sqrt(rcal)
21856 !        rcat0=3.472
21857 !        epscalc=0.05
21858 !        r06 = rcat0**6
21859 !        r012 = r06**2
21860 !        k0 = 332*(2*2)/80
21861         Evan1cat=epscalc*(r012/rcal**6)
21862         Evan2cat=epscalc*2*(r06/rcal**3)
21863         Eeleccat=k0/ract
21864         r7 = rcal**7
21865         r4 = rcal**4
21866         r(1)=xj
21867         r(2)=yj
21868         r(3)=zj
21869         do k=1,3
21870           dEvan1Cmcat(k)=-12*r(k)*epscalc*r012/r7
21871           dEvan2Cmcat(k)=-12*r(k)*epscalc*r06/r4
21872           dEeleccat(k)=-k0*r(k)/ract**3
21873         enddo
21874         do k=1,3
21875           gg(k) = dEvan1Cmcat(k)+dEvan2Cmcat(k)+dEeleccat(k)
21876           gradcatcat(k,i)=gradcatcat(k,i)-gg(k)
21877           gradcatcat(k,j)=gradcatcat(k,j)+gg(k)
21878         enddo
21879
21880 !        write(iout,*) "ecatcat",i,j, ecationcation,xj,yj,zj
21881         ecationcation=ecationcation+Evan1cat+Evan2cat+Eeleccat
21882        enddo
21883        enddo
21884        return
21885        end subroutine ecatcat
21886 !---------------------------------------------------------------------------
21887        subroutine ecat_prot(ecation_prot)
21888        integer i,j,k,subchap,itmp,inum
21889         real(kind=8) :: xi,yi,zi,xj,yj,zj,ract,rcat0,epscalc,r06,r012,&
21890         r7,r4,ecationcation
21891         real(kind=8) xj_temp,yj_temp,zj_temp,xj_safe,yj_safe,zj_safe, &
21892         dist_init,dist_temp,ecation_prot,rcal,rocal,   &
21893         Evan1,Evan2,EC,cm1mag,DASGL,delta,r0p,Epepcat, &
21894         catl,cml,calpl, Etotal_p, Etotal_m,rtab,wdip,wmodquad,wquad1, &
21895         wquad2,wvan1,E1,E2,wconst,wvan2,rcpm,dcmag,sin2thet,sinthet,  &
21896         costhet,v1m,v2m,wh2o,wc,rsecp,Ir,Irsecp,Irthrp,Irfourp,Irfiftp,&
21897         Irsistp,Irseven,Irtwelv,Irthir,dE1dr,dE2dr,dEdcos,wquad2p,opt, &
21898         rs,rthrp,rfourp,rsixp,reight,Irsixp,Ireight,Irtw,Irfourt,      &
21899         opt1,opt2,opt3,opt4,opt5,opt6,opt7,opt8,opt9,opt10,opt11,opt12,&
21900         opt13,opt14,opt15,opt16,opt17,opt18,opt19, &
21901         Equad1,Equad2,dscmag,v1dpv2,dscmag3,constA,constB,Edip
21902         real(kind=8),dimension(3) ::dEvan1Cmcat,dEvan2Cmcat,dEeleccat,&
21903         gg,r,EtotalCat,dEtotalCm,dEtotalCalp,dEvan1Cm,dEvan2Cm, &
21904         dEtotalpep,dEtotalcat_num,dEddci,dEtotalcm_num,dEtotalcalp_num, &
21905         tab1,tab2,tab3,diff,cm1,sc,p,tcat,talp,cm,drcp,drcp_norm,vcat,  &
21906         v1,v2,v3,myd_norm,dx,vcm,valpha,drdpep,dcosdpep,dcosddci,dEdpep,&
21907         dEcCat,dEdipCm,dEdipCalp,dEquad1Cat,dEquad1Cm,dEquad1Calp,      &
21908         dEquad2Cat,dEquad2Cm,dEquad2Calpd,Evan1Cat,dEvan1Calp,dEvan2Cat,&
21909         dEvan2Calp,dEtotalCat,dscvec,dEcCm,dEcCalp,dEdipCat,dEquad2Calp,&
21910         dEvan1Cat
21911         real(kind=8),dimension(6) :: vcatprm
21912         ecation_prot=0.0d0
21913 ! first lets calculate interaction with peptide groups
21914         if (nres_molec(5).eq.0) return
21915          wconst=78
21916         wdip =1.092777950857032D2
21917         wdip=wdip/wconst
21918         wmodquad=-2.174122713004870D4
21919         wmodquad=wmodquad/wconst
21920         wquad1 = 3.901232068562804D1
21921         wquad1=wquad1/wconst
21922         wquad2 = 3
21923         wquad2=wquad2/wconst
21924         wvan1 = 0.1
21925         wvan2 = 6
21926         itmp=0
21927         do i=1,4
21928         itmp=itmp+nres_molec(i)
21929         enddo
21930 !        do i=1,nres_molec(1)-1  ! loop over all peptide groups needs parralelization
21931         do i=ibond_start,ibond_end
21932 !         cycle
21933          if ((itype(i,1).eq.ntyp1).or.(itype(i+1,1).eq.ntyp1)) cycle ! leave dummy atoms
21934         xi=0.5d0*(c(1,i)+c(1,i+1))
21935         yi=0.5d0*(c(2,i)+c(2,i+1))
21936         zi=0.5d0*(c(3,i)+c(3,i+1))
21937           xi=mod(xi,boxxsize)
21938           if (xi.lt.0) xi=xi+boxxsize
21939           yi=mod(yi,boxysize)
21940           if (yi.lt.0) yi=yi+boxysize
21941           zi=mod(zi,boxzsize)
21942           if (zi.lt.0) zi=zi+boxzsize
21943
21944          do j=itmp+1,itmp+nres_molec(5)
21945            xj=c(1,j)
21946            yj=c(2,j)
21947            zj=c(3,j)
21948           xj=dmod(xj,boxxsize)
21949           if (xj.lt.0) xj=xj+boxxsize
21950           yj=dmod(yj,boxysize)
21951           if (yj.lt.0) yj=yj+boxysize
21952           zj=dmod(zj,boxzsize)
21953           if (zj.lt.0) zj=zj+boxzsize
21954       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21955       xj_safe=xj
21956       yj_safe=yj
21957       zj_safe=zj
21958       subchap=0
21959       do xshift=-1,1
21960       do yshift=-1,1
21961       do zshift=-1,1
21962           xj=xj_safe+xshift*boxxsize
21963           yj=yj_safe+yshift*boxysize
21964           zj=zj_safe+zshift*boxzsize
21965           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
21966           if(dist_temp.lt.dist_init) then
21967             dist_init=dist_temp
21968             xj_temp=xj
21969             yj_temp=yj
21970             zj_temp=zj
21971             subchap=1
21972           endif
21973        enddo
21974        enddo
21975        enddo
21976        if (subchap.eq.1) then
21977           xj=xj_temp-xi
21978           yj=yj_temp-yi
21979           zj=zj_temp-zi
21980        else
21981           xj=xj_safe-xi
21982           yj=yj_safe-yi
21983           zj=zj_safe-zi
21984        endif
21985 !       enddo
21986 !       enddo
21987        rcpm = sqrt(xj**2+yj**2+zj**2)
21988        drcp_norm(1)=xj/rcpm
21989        drcp_norm(2)=yj/rcpm
21990        drcp_norm(3)=zj/rcpm
21991        dcmag=0.0
21992        do k=1,3
21993        dcmag=dcmag+dc(k,i)**2
21994        enddo
21995        dcmag=dsqrt(dcmag)
21996        do k=1,3
21997          myd_norm(k)=dc(k,i)/dcmag
21998        enddo
21999         costhet=drcp_norm(1)*myd_norm(1)+drcp_norm(2)*myd_norm(2)+&
22000         drcp_norm(3)*myd_norm(3)
22001         rsecp = rcpm**2
22002         Ir = 1.0d0/rcpm
22003         Irsecp = 1.0d0/rsecp
22004         Irthrp = Irsecp/rcpm
22005         Irfourp = Irthrp/rcpm
22006         Irfiftp = Irfourp/rcpm
22007         Irsistp=Irfiftp/rcpm
22008         Irseven=Irsistp/rcpm
22009         Irtwelv=Irsistp*Irsistp
22010         Irthir=Irtwelv/rcpm
22011         sin2thet = (1-costhet*costhet)
22012         sinthet=sqrt(sin2thet)
22013         E1 = wdip*Irsecp*costhet+(wmodquad*Irfourp+wquad1*Irthrp)&
22014              *sin2thet
22015         E2 = -wquad1*Irthrp*wquad2+wvan1*(wvan2**12*Irtwelv-&
22016              2*wvan2**6*Irsistp)
22017         ecation_prot = ecation_prot+E1+E2
22018         dE1dr = -2*costhet*wdip*Irthrp-&
22019          (4*wmodquad*Irfiftp+3*wquad1*Irfourp)*sin2thet
22020         dE2dr = 3*wquad1*wquad2*Irfourp-     &
22021           12*wvan1*wvan2**6*(wvan2**6*Irthir-Irseven)
22022         dEdcos = wdip*Irsecp-2*(wmodquad*Irfourp+wquad1*Irthrp)*costhet
22023         do k=1,3
22024           drdpep(k) = -drcp_norm(k)
22025           dcosdpep(k) = Ir*(costhet*drcp_norm(k)-myd_norm(k))
22026           dcosddci(k) = drcp_norm(k)/dcmag-costhet*myd_norm(k)/dcmag
22027           dEdpep(k) = (dE1dr+dE2dr)*drdpep(k)+dEdcos*dcosdpep(k)
22028           dEddci(k) = dEdcos*dcosddci(k)
22029         enddo
22030         do k=1,3
22031         gradpepcat(k,i)=gradpepcat(k,i)+0.5D0*dEdpep(k)-dEddci(k)
22032         gradpepcat(k,i+1)=gradpepcat(k,i+1)+0.5D0*dEdpep(k)+dEddci(k)
22033         gradpepcat(k,j)=gradpepcat(k,j)-dEdpep(k)
22034         enddo
22035        enddo ! j
22036        enddo ! i
22037 !------------------------------------------sidechains
22038 !        do i=1,nres_molec(1)
22039         do i=ibond_start,ibond_end
22040          if ((itype(i,1).eq.ntyp1)) cycle ! leave dummy atoms
22041 !         cycle
22042 !        print *,i,ecation_prot
22043         xi=(c(1,i+nres))
22044         yi=(c(2,i+nres))
22045         zi=(c(3,i+nres))
22046           xi=mod(xi,boxxsize)
22047           if (xi.lt.0) xi=xi+boxxsize
22048           yi=mod(yi,boxysize)
22049           if (yi.lt.0) yi=yi+boxysize
22050           zi=mod(zi,boxzsize)
22051           if (zi.lt.0) zi=zi+boxzsize
22052           do k=1,3
22053             cm1(k)=dc(k,i+nres)
22054           enddo
22055            cm1mag=sqrt(cm1(1)**2+cm1(2)**2+cm1(3)**2)
22056          do j=itmp+1,itmp+nres_molec(5)
22057            xj=c(1,j)
22058            yj=c(2,j)
22059            zj=c(3,j)
22060           xj=dmod(xj,boxxsize)
22061           if (xj.lt.0) xj=xj+boxxsize
22062           yj=dmod(yj,boxysize)
22063           if (yj.lt.0) yj=yj+boxysize
22064           zj=dmod(zj,boxzsize)
22065           if (zj.lt.0) zj=zj+boxzsize
22066       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22067       xj_safe=xj
22068       yj_safe=yj
22069       zj_safe=zj
22070       subchap=0
22071       do xshift=-1,1
22072       do yshift=-1,1
22073       do zshift=-1,1
22074           xj=xj_safe+xshift*boxxsize
22075           yj=yj_safe+yshift*boxysize
22076           zj=zj_safe+zshift*boxzsize
22077           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22078           if(dist_temp.lt.dist_init) then
22079             dist_init=dist_temp
22080             xj_temp=xj
22081             yj_temp=yj
22082             zj_temp=zj
22083             subchap=1
22084           endif
22085        enddo
22086        enddo
22087        enddo
22088        if (subchap.eq.1) then
22089           xj=xj_temp-xi
22090           yj=yj_temp-yi
22091           zj=zj_temp-zi
22092        else
22093           xj=xj_safe-xi
22094           yj=yj_safe-yi
22095           zj=zj_safe-zi
22096        endif
22097 !       enddo
22098 !       enddo
22099          if(itype(i,1).eq.15.or.itype(i,1).eq.16) then
22100             if(itype(i,1).eq.16) then
22101             inum=1
22102             else
22103             inum=2
22104             endif
22105             do k=1,6
22106             vcatprm(k)=catprm(k,inum)
22107             enddo
22108             dASGL=catprm(7,inum)
22109              do k=1,3
22110                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22111                 valpha(k)=c(k,i)
22112                 vcat(k)=c(k,j)
22113               enddo
22114                       do k=1,3
22115           dx(k) = vcat(k)-vcm(k)
22116         enddo
22117         do k=1,3
22118           v1(k)=(vcm(k)-valpha(k))
22119           v2(k)=(vcat(k)-valpha(k))
22120         enddo
22121         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22122         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22123         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22124
22125 !  The weights of the energy function calculated from
22126 !The quantum mechanical GAMESS simulations of calcium with ASP/GLU
22127         wh2o=78
22128         wc = vcatprm(1)
22129         wc=wc/wh2o
22130         wdip =vcatprm(2)
22131         wdip=wdip/wh2o
22132         wquad1 =vcatprm(3)
22133         wquad1=wquad1/wh2o
22134         wquad2 = vcatprm(4)
22135         wquad2=wquad2/wh2o
22136         wquad2p = 1-wquad2
22137         wvan1 = vcatprm(5)
22138         wvan2 =vcatprm(6)
22139         opt = dx(1)**2+dx(2)**2
22140         rsecp = opt+dx(3)**2
22141         rs = sqrt(rsecp)
22142         rthrp = rsecp*rs
22143         rfourp = rthrp*rs
22144         rsixp = rfourp*rsecp
22145         reight=rsixp*rsecp
22146         Ir = 1.0d0/rs
22147         Irsecp = 1/rsecp
22148         Irthrp = Irsecp/rs
22149         Irfourp = Irthrp/rs
22150         Irsixp = 1/rsixp
22151         Ireight=1/reight
22152         Irtw=Irsixp*Irsixp
22153         Irthir=Irtw/rs
22154         Irfourt=Irthir/rs
22155         opt1 = (4*rs*dx(3)*wdip)
22156         opt2 = 6*rsecp*wquad1*opt
22157         opt3 = wquad1*wquad2p*Irsixp
22158         opt4 = (wvan1*wvan2**12)
22159         opt5 = opt4*12*Irfourt
22160         opt6 = 2*wvan1*wvan2**6
22161         opt7 = 6*opt6*Ireight
22162         opt8 = wdip/v1m
22163         opt10 = wdip/v2m
22164         opt11 = (rsecp*v2m)**2
22165         opt12 = (rsecp*v1m)**2
22166         opt14 = (v1m*v2m*rsecp)**2
22167         opt15 = -wquad1/v2m**2
22168         opt16 = (rthrp*(v1m*v2m)**2)**2
22169         opt17 = (v1m**2*rthrp)**2
22170         opt18 = -wquad1/rthrp
22171         opt19 = (v1m**2*v2m**2)**2
22172         Ec = wc*Ir
22173         do k=1,3
22174           dEcCat(k) = -(dx(k)*wc)*Irthrp
22175           dEcCm(k)=(dx(k)*wc)*Irthrp
22176           dEcCalp(k)=0.0d0
22177         enddo
22178         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22179         do k=1,3
22180           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m &
22181                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22182           dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m &
22183                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22184           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m &
22185                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp) &
22186                       *v1dpv2)/opt14
22187         enddo
22188         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22189         do k=1,3
22190           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp* &
22191                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2* &
22192                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22193           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp* &
22194                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2* &
22195                       v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22196           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22197                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)* &
22198                         v1dpv2**2)/opt19
22199         enddo
22200         Equad2=wquad1*wquad2p*Irthrp
22201         do k=1,3
22202           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22203           dEquad2Cm(k)=3*dx(k)*rs*opt3
22204           dEquad2Calp(k)=0.0d0
22205         enddo
22206         Evan1=opt4*Irtw
22207         do k=1,3
22208           dEvan1Cat(k)=-dx(k)*opt5
22209           dEvan1Cm(k)=dx(k)*opt5
22210           dEvan1Calp(k)=0.0d0
22211         enddo
22212         Evan2=-opt6*Irsixp
22213         do k=1,3
22214           dEvan2Cat(k)=dx(k)*opt7
22215           dEvan2Cm(k)=-dx(k)*opt7
22216           dEvan2Calp(k)=0.0d0
22217         enddo
22218         ecation_prot=ecation_prot+Ec+Edip+Equad1+Equad2+Evan1+Evan2
22219 !        print *,ecation_prot,Ec+Edip+Equad1+Equad2+Evan1+Evan2
22220
22221         do k=1,3
22222           dEtotalCat(k)=dEcCat(k)+dEdipCat(k)+dEquad1Cat(k)+ &
22223                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22224 !c             write(*,*) 'dEtotalCat inside', (dEtotalCat(l),l=1,3)
22225           dEtotalCm(k)=dEcCm(k)+dEdipCm(k)+dEquad1Cm(k)+ &
22226                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22227           dEtotalCalp(k)=dEcCalp(k)+dEdipCalp(k)+dEquad1Calp(k) &
22228                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22229         enddo
22230             dscmag = 0.0d0
22231             do k=1,3
22232               dscvec(k) = dc(k,i+nres)
22233               dscmag = dscmag+dscvec(k)*dscvec(k)
22234             enddo
22235             dscmag3 = dscmag
22236             dscmag = sqrt(dscmag)
22237             dscmag3 = dscmag3*dscmag
22238             constA = 1.0d0+dASGL/dscmag
22239             constB = 0.0d0
22240             do k=1,3
22241               constB = constB+dscvec(k)*dEtotalCm(k)
22242             enddo
22243             constB = constB*dASGL/dscmag3
22244             do k=1,3
22245               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22246               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22247                constA*dEtotalCm(k)-constB*dscvec(k)
22248 !            print *,j,constA,dEtotalCm(k),constB,dscvec(k)
22249               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22250               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22251              enddo
22252         else if (itype(i,1).eq.13.or.itype(i,1).eq.14) then
22253            if(itype(i,1).eq.14) then
22254             inum=3
22255             else
22256             inum=4
22257             endif
22258             do k=1,6
22259             vcatprm(k)=catprm(k,inum)
22260             enddo
22261             dASGL=catprm(7,inum)
22262              do k=1,3
22263                 vcm(k)=(cm1(k)/cm1mag)*dASGL+c(k,i+nres)
22264                 valpha(k)=c(k,i)
22265                 vcat(k)=c(k,j)
22266               enddo
22267
22268         do k=1,3
22269           dx(k) = vcat(k)-vcm(k)
22270         enddo
22271         do k=1,3
22272           v1(k)=(vcm(k)-valpha(k))
22273           v2(k)=(vcat(k)-valpha(k))
22274         enddo
22275         v1m = sqrt(v1(1)**2+v1(2)**2+v1(3)**2)
22276         v2m = sqrt(v2(1)**2+v2(2)**2+v2(3)**2)
22277         v1dpv2 = v1(1)*v2(1)+v1(2)*v2(2)+v1(3)*v2(3)
22278 !  The weights of the energy function calculated from
22279 !The quantum mechanical GAMESS simulations of ASN/GLN with calcium
22280         wh2o=78
22281         wdip =vcatprm(2)
22282         wdip=wdip/wh2o
22283         wquad1 =vcatprm(3)
22284         wquad1=wquad1/wh2o
22285         wquad2 = vcatprm(4)
22286         wquad2=wquad2/wh2o
22287         wquad2p = 1-wquad2
22288         wvan1 = vcatprm(5)
22289         wvan2 =vcatprm(6)
22290         opt = dx(1)**2+dx(2)**2
22291         rsecp = opt+dx(3)**2
22292         rs = sqrt(rsecp)
22293         rthrp = rsecp*rs
22294         rfourp = rthrp*rs
22295         rsixp = rfourp*rsecp
22296         reight=rsixp*rsecp
22297         Ir = 1.0d0/rs
22298         Irsecp = 1/rsecp
22299         Irthrp = Irsecp/rs
22300         Irfourp = Irthrp/rs
22301         Irsixp = 1/rsixp
22302         Ireight=1/reight
22303         Irtw=Irsixp*Irsixp
22304         Irthir=Irtw/rs
22305         Irfourt=Irthir/rs
22306         opt1 = (4*rs*dx(3)*wdip)
22307         opt2 = 6*rsecp*wquad1*opt
22308         opt3 = wquad1*wquad2p*Irsixp
22309         opt4 = (wvan1*wvan2**12)
22310         opt5 = opt4*12*Irfourt
22311         opt6 = 2*wvan1*wvan2**6
22312         opt7 = 6*opt6*Ireight
22313         opt8 = wdip/v1m
22314         opt10 = wdip/v2m
22315         opt11 = (rsecp*v2m)**2
22316         opt12 = (rsecp*v1m)**2
22317         opt14 = (v1m*v2m*rsecp)**2
22318         opt15 = -wquad1/v2m**2
22319         opt16 = (rthrp*(v1m*v2m)**2)**2
22320         opt17 = (v1m**2*rthrp)**2
22321         opt18 = -wquad1/rthrp
22322         opt19 = (v1m**2*v2m**2)**2
22323         Edip=opt8*(v1dpv2)/(rsecp*v2m)
22324         do k=1,3
22325           dEdipCat(k)=opt8*(v1(k)*rsecp*v2m-((v2(k)/v2m&
22326                      *rsecp+2*dx(k)*v2m)*v1dpv2))/opt11
22327          dEdipCm(k)=opt10*(v2(k)*rsecp*v1m-((v1(k)/v1m&
22328                     *rsecp-2*dx(k)*v1m)*v1dpv2))/opt12
22329           dEdipCalp(k)=wdip*((-v1(k)-v2(k))*rsecp*v1m&
22330                       *v2m-(-v1(k)/v1m*v2m*rsecp-v2(k)/v2m*v1m*rsecp)&
22331                       *v1dpv2)/opt14
22332         enddo
22333         Equad1=-wquad1*v1dpv2**2/(rthrp*(v1m*v2m)**2)
22334         do k=1,3
22335           dEquad1Cat(k)=-wquad1*(2*v1(k)*v1dpv2*(rthrp*&
22336                        (v1m*v2m)**2)-(3*dx(k)*rs*(v1m*v2m)**2+2*v1m*2*&
22337                        v2(k)*1/2*1/v2m*v1m*v2m*rthrp)*v1dpv2**2)/opt16
22338           dEquad1Cm(k)=-wquad1*(2*v2(k)*v1dpv2*(rthrp*&
22339                       (v1m*v2m)**2)-(-3*dx(k)*rs*(v1m*v2m)**2+2*v2m*2*&
22340                        v1(k)*1/2*1/v1m*v2m*v1m*rthrp)*v1dpv2**2)/opt16
22341           dEquad1Calp(k)=opt18*(2*(-v1(k)-v2(k))*v1dpv2* &
22342                         v1m**2*v2m**2-(-2*v1(k)*v2m**2-2*v2(k)*v1m**2)*&
22343                         v1dpv2**2)/opt19
22344         enddo
22345         Equad2=wquad1*wquad2p*Irthrp
22346         do k=1,3
22347           dEquad2Cat(k)=-3*dx(k)*rs*opt3
22348           dEquad2Cm(k)=3*dx(k)*rs*opt3
22349           dEquad2Calp(k)=0.0d0
22350         enddo
22351         Evan1=opt4*Irtw
22352         do k=1,3
22353           dEvan1Cat(k)=-dx(k)*opt5
22354           dEvan1Cm(k)=dx(k)*opt5
22355           dEvan1Calp(k)=0.0d0
22356         enddo
22357         Evan2=-opt6*Irsixp
22358         do k=1,3
22359           dEvan2Cat(k)=dx(k)*opt7
22360           dEvan2Cm(k)=-dx(k)*opt7
22361           dEvan2Calp(k)=0.0d0
22362         enddo
22363          ecation_prot = ecation_prot+Edip+Equad1+Equad2+Evan1+Evan2
22364         do k=1,3
22365           dEtotalCat(k)=dEdipCat(k)+dEquad1Cat(k)+ &
22366                        dEquad2Cat(k)+dEvan1Cat(k)+dEvan2Cat(k)
22367           dEtotalCm(k)=dEdipCm(k)+dEquad1Cm(k)+ &
22368                       dEquad2Cm(k)+dEvan1Cm(k)+dEvan2Cm(k)
22369           dEtotalCalp(k)=dEdipCalp(k)+dEquad1Calp(k) &
22370                         +dEquad2Calp(k)+dEvan1Calp(k)+dEvan2Calp(k)
22371         enddo
22372             dscmag = 0.0d0
22373             do k=1,3
22374               dscvec(k) = c(k,i+nres)-c(k,i)
22375               dscmag = dscmag+dscvec(k)*dscvec(k)
22376             enddo
22377             dscmag3 = dscmag
22378             dscmag = sqrt(dscmag)
22379             dscmag3 = dscmag3*dscmag
22380             constA = 1+dASGL/dscmag
22381             constB = 0.0d0
22382             do k=1,3
22383               constB = constB+dscvec(k)*dEtotalCm(k)
22384             enddo
22385             constB = constB*dASGL/dscmag3
22386             do k=1,3
22387               gg(k) = dEtotalCm(k)+dEtotalCalp(k)
22388               gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22389                constA*dEtotalCm(k)-constB*dscvec(k)
22390               gradpepcat(k,i)=gradpepcat(k,i)+gg(k)
22391               gradpepcat(k,j)=gradpepcat(k,j)+dEtotalCat(k)
22392              enddo
22393            else
22394             rcal = 0.0d0
22395             do k=1,3
22396               r(k) = c(k,j)-c(k,i+nres)
22397               rcal = rcal+r(k)*r(k)
22398             enddo
22399             ract=sqrt(rcal)
22400             rocal=1.5
22401             epscalc=0.2
22402             r0p=0.5*(rocal+sig0(itype(i,1)))
22403             r06 = r0p**6
22404             r012 = r06*r06
22405             Evan1=epscalc*(r012/rcal**6)
22406             Evan2=epscalc*2*(r06/rcal**3)
22407             r4 = rcal**4
22408             r7 = rcal**7
22409             do k=1,3
22410               dEvan1Cm(k) = 12*r(k)*epscalc*r012/r7
22411               dEvan2Cm(k) = 12*r(k)*epscalc*r06/r4
22412             enddo
22413             do k=1,3
22414               dEtotalCm(k)=dEvan1Cm(k)+dEvan2Cm(k)
22415             enddo
22416                  ecation_prot = ecation_prot+ Evan1+Evan2
22417             do  k=1,3
22418                gradpepcatx(k,i)=gradpepcatx(k,i)+ &
22419                dEtotalCm(k)
22420               gradpepcat(k,i)=gradpepcat(k,i)+dEtotalCm(k)
22421               gradpepcat(k,j)=gradpepcat(k,j)-dEtotalCm(k)
22422              enddo
22423          endif ! 13-16 residues
22424        enddo !j
22425        enddo !i
22426        return
22427        end subroutine ecat_prot
22428
22429 !----------------------------------------------------------------------------
22430 !-----------------------------------------------------------------------------
22431 !-----------------------------------------------------------------------------
22432       subroutine eprot_sc_base(escbase)
22433       use calc_data
22434 !      implicit real*8 (a-h,o-z)
22435 !      include 'DIMENSIONS'
22436 !      include 'COMMON.GEO'
22437 !      include 'COMMON.VAR'
22438 !      include 'COMMON.LOCAL'
22439 !      include 'COMMON.CHAIN'
22440 !      include 'COMMON.DERIV'
22441 !      include 'COMMON.NAMES'
22442 !      include 'COMMON.INTERACT'
22443 !      include 'COMMON.IOUNITS'
22444 !      include 'COMMON.CALC'
22445 !      include 'COMMON.CONTROL'
22446 !      include 'COMMON.SBRIDGE'
22447       logical :: lprn
22448 !el local variables
22449       integer :: iint,itypi,itypi1,itypj,subchap
22450       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
22451       real(kind=8) :: evdw,sig0ij
22452       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22453                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
22454                     sslipi,sslipj,faclip
22455       integer :: ii
22456       real(kind=8) :: fracinbuf
22457        real (kind=8) :: escbase
22458        real (kind=8),dimension(4):: ener
22459        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
22460        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
22461         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
22462         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
22463         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
22464         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
22465         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
22466         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
22467        real(kind=8),dimension(3,2)::chead,erhead_tail
22468        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
22469        integer troll
22470        eps_out=80.0d0
22471        escbase=0.0d0
22472 !       do i=1,nres_molec(1)
22473         do i=ibond_start,ibond_end
22474         if (itype(i,1).eq.ntyp1_molec(1)) cycle
22475         itypi  = itype(i,1)
22476         dxi    = dc_norm(1,nres+i)
22477         dyi    = dc_norm(2,nres+i)
22478         dzi    = dc_norm(3,nres+i)
22479         dsci_inv = vbld_inv(i+nres)
22480         xi=c(1,nres+i)
22481         yi=c(2,nres+i)
22482         zi=c(3,nres+i)
22483         xi=mod(xi,boxxsize)
22484          if (xi.lt.0) xi=xi+boxxsize
22485         yi=mod(yi,boxysize)
22486          if (yi.lt.0) yi=yi+boxysize
22487         zi=mod(zi,boxzsize)
22488          if (zi.lt.0) zi=zi+boxzsize
22489          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
22490            itypj= itype(j,2)
22491            if (itype(j,2).eq.ntyp1_molec(2))cycle
22492            xj=c(1,j+nres)
22493            yj=c(2,j+nres)
22494            zj=c(3,j+nres)
22495            xj=dmod(xj,boxxsize)
22496            if (xj.lt.0) xj=xj+boxxsize
22497            yj=dmod(yj,boxysize)
22498            if (yj.lt.0) yj=yj+boxysize
22499            zj=dmod(zj,boxzsize)
22500            if (zj.lt.0) zj=zj+boxzsize
22501           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22502           xj_safe=xj
22503           yj_safe=yj
22504           zj_safe=zj
22505           subchap=0
22506
22507           do xshift=-1,1
22508           do yshift=-1,1
22509           do zshift=-1,1
22510           xj=xj_safe+xshift*boxxsize
22511           yj=yj_safe+yshift*boxysize
22512           zj=zj_safe+zshift*boxzsize
22513           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
22514           if(dist_temp.lt.dist_init) then
22515             dist_init=dist_temp
22516             xj_temp=xj
22517             yj_temp=yj
22518             zj_temp=zj
22519             subchap=1
22520           endif
22521           enddo
22522           enddo
22523           enddo
22524           if (subchap.eq.1) then
22525           xj=xj_temp-xi
22526           yj=yj_temp-yi
22527           zj=zj_temp-zi
22528           else
22529           xj=xj_safe-xi
22530           yj=yj_safe-yi
22531           zj=zj_safe-zi
22532           endif
22533           dxj = dc_norm( 1, nres+j )
22534           dyj = dc_norm( 2, nres+j )
22535           dzj = dc_norm( 3, nres+j )
22536 !          print *,i,j,itypi,itypj
22537           d1i = dhead_scbasei(itypi,itypj) !this is shift of dipole/charge
22538           d1j = dhead_scbasej(itypi,itypj) !this is shift of dipole/charge
22539 !          d1i=0.0d0
22540 !          d1j=0.0d0
22541 !          BetaT = 1.0d0 / (298.0d0 * Rb)
22542 ! Gay-berne var's
22543           sig0ij = sigma_scbase( itypi,itypj )
22544           chi1   = chi_scbase( itypi, itypj,1 )
22545           chi2   = chi_scbase( itypi, itypj,2 )
22546 !          chi1=0.0d0
22547 !          chi2=0.0d0
22548           chi12  = chi1 * chi2
22549           chip1  = chipp_scbase( itypi, itypj,1 )
22550           chip2  = chipp_scbase( itypi, itypj,2 )
22551 !          chip1=0.0d0
22552 !          chip2=0.0d0
22553           chip12 = chip1 * chip2
22554 ! not used by momo potential, but needed by sc_angular which is shared
22555 ! by all energy_potential subroutines
22556           alf1   = 0.0d0
22557           alf2   = 0.0d0
22558           alf12  = 0.0d0
22559           a12sq = rborn_scbasei(itypi,itypj) * rborn_scbasej(itypi,itypj)
22560 !       a12sq = a12sq * a12sq
22561 ! charge of amino acid itypi is...
22562           chis1 = chis_scbase(itypi,itypj,1)
22563           chis2 = chis_scbase(itypi,itypj,2)
22564           chis12 = chis1 * chis2
22565           sig1 = sigmap1_scbase(itypi,itypj)
22566           sig2 = sigmap2_scbase(itypi,itypj)
22567 !       write (*,*) "sig1 = ", sig1
22568 !       write (*,*) "sig2 = ", sig2
22569 ! alpha factors from Fcav/Gcav
22570           b1 = alphasur_scbase(1,itypi,itypj)
22571 !          b1=0.0d0
22572           b2 = alphasur_scbase(2,itypi,itypj)
22573           b3 = alphasur_scbase(3,itypi,itypj)
22574           b4 = alphasur_scbase(4,itypi,itypj)
22575 ! used to determine whether we want to do quadrupole calculations
22576 ! used by Fgb
22577        eps_in = epsintab_scbase(itypi,itypj)
22578        if (eps_in.eq.0.0) eps_in=1.0
22579        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
22580 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
22581 !-------------------------------------------------------------------
22582 ! tail location and distance calculations
22583        DO k = 1,3
22584 ! location of polar head is computed by taking hydrophobic centre
22585 ! and moving by a d1 * dc_norm vector
22586 ! see unres publications for very informative images
22587         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
22588         chead(k,2) = c(k, j+nres) + d1j * dc_norm(k, j+nres)
22589 ! distance
22590 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
22591 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
22592         Rhead_distance(k) = chead(k,2) - chead(k,1)
22593        END DO
22594 ! pitagoras (root of sum of squares)
22595        Rhead = dsqrt( &
22596           (Rhead_distance(1)*Rhead_distance(1)) &
22597         + (Rhead_distance(2)*Rhead_distance(2)) &
22598         + (Rhead_distance(3)*Rhead_distance(3)))
22599 !-------------------------------------------------------------------
22600 ! zero everything that should be zero'ed
22601        evdwij = 0.0d0
22602        ECL = 0.0d0
22603        Elj = 0.0d0
22604        Equad = 0.0d0
22605        Epol = 0.0d0
22606        Fcav=0.0d0
22607        eheadtail = 0.0d0
22608        dGCLdOM1 = 0.0d0
22609        dGCLdOM2 = 0.0d0
22610        dGCLdOM12 = 0.0d0
22611        dPOLdOM1 = 0.0d0
22612        dPOLdOM2 = 0.0d0
22613           Fcav = 0.0d0
22614           dFdR = 0.0d0
22615           dCAVdOM1  = 0.0d0
22616           dCAVdOM2  = 0.0d0
22617           dCAVdOM12 = 0.0d0
22618           dscj_inv = vbld_inv(j+nres)
22619 !          print *,i,j,dscj_inv,dsci_inv
22620 ! rij holds 1/(distance of Calpha atoms)
22621           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
22622           rij  = dsqrt(rrij)
22623 !----------------------------
22624           CALL sc_angular
22625 ! this should be in elgrad_init but om's are calculated by sc_angular
22626 ! which in turn is used by older potentials
22627 ! om = omega, sqom = om^2
22628           sqom1  = om1 * om1
22629           sqom2  = om2 * om2
22630           sqom12 = om12 * om12
22631
22632 ! now we calculate EGB - Gey-Berne
22633 ! It will be summed up in evdwij and saved in evdw
22634           sigsq     = 1.0D0  / sigsq
22635           sig       = sig0ij * dsqrt(sigsq)
22636 !          rij_shift = 1.0D0  / rij - sig + sig0ij
22637           rij_shift = 1.0/rij - sig + sig0ij
22638           IF (rij_shift.le.0.0D0) THEN
22639            evdw = 1.0D20
22640            RETURN
22641           END IF
22642           sigder = -sig * sigsq
22643           rij_shift = 1.0D0 / rij_shift
22644           fac       = rij_shift**expon
22645           c1        = fac  * fac * aa_scbase(itypi,itypj)
22646 !          c1        = 0.0d0
22647           c2        = fac  * bb_scbase(itypi,itypj)
22648 !          c2        = 0.0d0
22649           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
22650           eps2der   = eps3rt * evdwij
22651           eps3der   = eps2rt * evdwij
22652 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
22653           evdwij    = eps2rt * eps3rt * evdwij
22654           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
22655           fac    = -expon * (c1 + evdwij) * rij_shift
22656           sigder = fac * sigder
22657 !          fac    = rij * fac
22658 ! Calculate distance derivative
22659           gg(1) =  fac
22660           gg(2) =  fac
22661           gg(3) =  fac
22662 !          if (b2.gt.0.0) then
22663           fac = chis1 * sqom1 + chis2 * sqom2 &
22664           - 2.0d0 * chis12 * om1 * om2 * om12
22665 ! we will use pom later in Gcav, so dont mess with it!
22666           pom = 1.0d0 - chis1 * chis2 * sqom12
22667           Lambf = (1.0d0 - (fac / pom))
22668           Lambf = dsqrt(Lambf)
22669           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
22670 !       write (*,*) "sparrow = ", sparrow
22671           Chif = 1.0d0/rij * sparrow
22672           ChiLambf = Chif * Lambf
22673           eagle = dsqrt(ChiLambf)
22674           bat = ChiLambf ** 11.0d0
22675           top = b1 * ( eagle + b2 * ChiLambf - b3 )
22676           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
22677           botsq = bot * bot
22678           Fcav = top / bot
22679 !          print *,i,j,Fcav
22680           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
22681           dbot = 12.0d0 * b4 * bat * Lambf
22682           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
22683 !       dFdR = 0.0d0
22684 !      write (*,*) "dFcav/dR = ", dFdR
22685           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
22686           dbot = 12.0d0 * b4 * bat * Chif
22687           eagle = Lambf * pom
22688           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
22689           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
22690           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
22691               * (chis2 * om2 * om12 - om1) / (eagle * pom)
22692
22693           dFdL = ((dtop * bot - top * dbot) / botsq)
22694 !       dFdL = 0.0d0
22695           dCAVdOM1  = dFdL * ( dFdOM1 )
22696           dCAVdOM2  = dFdL * ( dFdOM2 )
22697           dCAVdOM12 = dFdL * ( dFdOM12 )
22698
22699           ertail(1) = xj*rij
22700           ertail(2) = yj*rij
22701           ertail(3) = zj*rij
22702 !      eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
22703 !      eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
22704 !      eom12=evdwij*eps1_om12+eps2der*eps2rt_om12 &
22705 !          -2.0D0*alf12*eps3der+sigder*sigsq_om12
22706 !           print *,"EOMY",eom1,eom2,eom12
22707 !          erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
22708 !          erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
22709 ! here dtail=0.0
22710 !          facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
22711 !          facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
22712        DO k = 1, 3
22713 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
22714 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
22715         pom = ertail(k)
22716 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
22717         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
22718                   - (( dFdR + gg(k) ) * pom)
22719 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
22720 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22721 !     &             - ( dFdR * pom )
22722         pom = ertail(k)
22723 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
22724         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
22725                   + (( dFdR + gg(k) ) * pom)
22726 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22727 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22728 !c!     &             + ( dFdR * pom )
22729
22730         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
22731                   - (( dFdR + gg(k) ) * ertail(k))
22732 !c!     &             - ( dFdR * ertail(k))
22733
22734         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
22735                   + (( dFdR + gg(k) ) * ertail(k))
22736 !c!     &             + ( dFdR * ertail(k))
22737
22738         gg(k) = 0.0d0
22739 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
22740 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
22741       END DO
22742
22743 !          else
22744
22745 !          endif
22746 !Now dipole-dipole
22747          if (wdipdip_scbase(2,itypi,itypj).gt.0.0d0) then
22748        w1 = wdipdip_scbase(1,itypi,itypj)
22749        w2 = -wdipdip_scbase(3,itypi,itypj)/2.0
22750        w3 = wdipdip_scbase(2,itypi,itypj)
22751 !c!-------------------------------------------------------------------
22752 !c! ECL
22753        fac = (om12 - 3.0d0 * om1 * om2)
22754        c1 = (w1 / (Rhead**3.0d0)) * fac
22755        c2 = (w2 / Rhead ** 6.0d0)  &
22756          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
22757        c3= (w3/ Rhead ** 6.0d0)  &
22758          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
22759        ECL = c1 - c2 + c3
22760 !c!       write (*,*) "w1 = ", w1
22761 !c!       write (*,*) "w2 = ", w2
22762 !c!       write (*,*) "om1 = ", om1
22763 !c!       write (*,*) "om2 = ", om2
22764 !c!       write (*,*) "om12 = ", om12
22765 !c!       write (*,*) "fac = ", fac
22766 !c!       write (*,*) "c1 = ", c1
22767 !c!       write (*,*) "c2 = ", c2
22768 !c!       write (*,*) "Ecl = ", Ecl
22769 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
22770 !c!       write (*,*) "c2_2 = ",
22771 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
22772 !c!-------------------------------------------------------------------
22773 !c! dervative of ECL is GCL...
22774 !c! dECL/dr
22775        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
22776        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
22777          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
22778        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
22779          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
22780        dGCLdR = c1 - c2 + c3
22781 !c! dECL/dom1
22782        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
22783        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
22784          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
22785        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
22786        dGCLdOM1 = c1 - c2 + c3
22787 !c! dECL/dom2
22788        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
22789        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
22790          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
22791        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
22792        dGCLdOM2 = c1 - c2 + c3
22793 !c! dECL/dom12
22794        c1 = w1 / (Rhead ** 3.0d0)
22795        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
22796        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
22797        dGCLdOM12 = c1 - c2 + c3
22798        DO k= 1, 3
22799         erhead(k) = Rhead_distance(k)/Rhead
22800        END DO
22801        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
22802        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
22803        facd1 = d1i * vbld_inv(i+nres)
22804        facd2 = d1j * vbld_inv(j+nres)
22805        DO k = 1, 3
22806
22807         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
22808         gvdwx_scbase(k,i) = gvdwx_scbase(k,i) &
22809                   - dGCLdR * pom
22810         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
22811         gvdwx_scbase(k,j) = gvdwx_scbase(k,j) &
22812                   + dGCLdR * pom
22813
22814         gvdwc_scbase(k,i) = gvdwc_scbase(k,i) &
22815                   - dGCLdR * erhead(k)
22816         gvdwc_scbase(k,j) = gvdwc_scbase(k,j) &
22817                   + dGCLdR * erhead(k)
22818        END DO
22819        endif
22820 !now charge with dipole eg. ARG-dG
22821        if (wqdip_scbase(2,itypi,itypj).gt.0.0d0) then
22822       alphapol1 = alphapol_scbase(itypi,itypj)
22823        w1        = wqdip_scbase(1,itypi,itypj)
22824        w2        = wqdip_scbase(2,itypi,itypj)
22825 !       w1=0.0d0
22826 !       w2=0.0d0
22827 !       pis       = sig0head_scbase(itypi,itypj)
22828 !       eps_head   = epshead_scbase(itypi,itypj)
22829 !c!-------------------------------------------------------------------
22830 !c! R1 - distance between head of ith side chain and tail of jth sidechain
22831        R1 = 0.0d0
22832        DO k = 1, 3
22833 !c! Calculate head-to-tail distances tail is center of side-chain
22834         R1=R1+(c(k,j+nres)-chead(k,1))**2
22835        END DO
22836 !c! Pitagoras
22837        R1 = dsqrt(R1)
22838
22839 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
22840 !c!     &        +dhead(1,1,itypi,itypj))**2))
22841 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
22842 !c!     &        +dhead(2,1,itypi,itypj))**2))
22843
22844 !c!-------------------------------------------------------------------
22845 !c! ecl
22846        sparrow  = w1  *  om1
22847        hawk     = w2 *  (1.0d0 - sqom2)
22848        Ecl = sparrow / Rhead**2.0d0 &
22849            - hawk    / Rhead**4.0d0
22850 !c!-------------------------------------------------------------------
22851 !c! derivative of ecl is Gcl
22852 !c! dF/dr part
22853        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
22854                 + 4.0d0 * hawk    / Rhead**5.0d0
22855 !c! dF/dom1
22856        dGCLdOM1 = (w1) / (Rhead**2.0d0)
22857 !c! dF/dom2
22858        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
22859 !c--------------------------------------------------------------------
22860 !c Polarization energy
22861 !c Epol
22862        MomoFac1 = (1.0d0 - chi1 * sqom2)
22863        RR1  = R1 * R1 / MomoFac1
22864        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
22865        fgb1 = sqrt( RR1 + a12sq * ee1)
22866 !       eps_inout_fac=0.0d0
22867        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
22868 ! derivative of Epol is Gpol...
22869        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
22870                 / (fgb1 ** 5.0d0)
22871        dFGBdR1 = ( (R1 / MomoFac1) &
22872              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
22873              / ( 2.0d0 * fgb1 )
22874        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
22875                * (2.0d0 - 0.5d0 * ee1) ) &
22876                / (2.0d0 * fgb1)
22877        dPOLdR1 = dPOLdFGB1 * dFGBdR1
22878 !       dPOLdR1 = 0.0d0
22879        dPOLdOM1 = 0.0d0
22880        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
22881        DO k = 1, 3
22882         erhead(k) = Rhead_distance(k)/Rhead
22883         erhead_tail(k,1) = ((c(k,j+nres)-chead(k,1))/R1)
22884        END DO
22885
22886        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
22887        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
22888        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
22889 !       bat=0.0d0
22890        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
22891        facd1 = d1i * vbld_inv(i+nres)
22892        facd2 = d1j * vbld_inv(j+nres)
22893 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
22894
22895        DO k = 1, 3
22896         hawk = (erhead_tail(k,1) + &
22897         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
22898 !        facd1=0.0d0
22899 !        facd2=0.0d0
22900         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
22901         gvdwx_scbase(k,i) = gvdwx_scbase(k,i)   &
22902                    - dGCLdR * pom &
22903                    - dPOLdR1 *  (erhead_tail(k,1))
22904 !     &             - dGLJdR * pom
22905
22906         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
22907         gvdwx_scbase(k,j) = gvdwx_scbase(k,j)    &
22908                    + dGCLdR * pom  &
22909                    + dPOLdR1 * (erhead_tail(k,1))
22910 !     &             + dGLJdR * pom
22911
22912
22913         gvdwc_scbase(k,i) = gvdwc_scbase(k,i)  &
22914                   - dGCLdR * erhead(k) &
22915                   - dPOLdR1 * erhead_tail(k,1)
22916 !     &             - dGLJdR * erhead(k)
22917
22918         gvdwc_scbase(k,j) = gvdwc_scbase(k,j)         &
22919                   + dGCLdR * erhead(k)  &
22920                   + dPOLdR1 * erhead_tail(k,1)
22921 !     &             + dGLJdR * erhead(k)
22922
22923        END DO
22924        endif
22925 !       print *,i,j,evdwij,epol,Fcav,ECL
22926        escbase=escbase+evdwij+epol+Fcav+ECL
22927        call sc_grad_scbase
22928          enddo
22929       enddo
22930
22931       return
22932       end subroutine eprot_sc_base
22933       SUBROUTINE sc_grad_scbase
22934       use calc_data
22935
22936        real (kind=8) :: dcosom1(3),dcosom2(3)
22937        eom1  =    &
22938               eps2der * eps2rt_om1   &
22939             - 2.0D0 * alf1 * eps3der &
22940             + sigder * sigsq_om1     &
22941             + dCAVdOM1               &
22942             + dGCLdOM1               &
22943             + dPOLdOM1
22944
22945        eom2  =  &
22946               eps2der * eps2rt_om2   &
22947             + 2.0D0 * alf2 * eps3der &
22948             + sigder * sigsq_om2     &
22949             + dCAVdOM2               &
22950             + dGCLdOM2               &
22951             + dPOLdOM2
22952
22953        eom12 =    &
22954               evdwij  * eps1_om12     &
22955             + eps2der * eps2rt_om12   &
22956             - 2.0D0 * alf12 * eps3der &
22957             + sigder *sigsq_om12      &
22958             + dCAVdOM12               &
22959             + dGCLdOM12
22960
22961 !       print *,eom1,eom2,eom12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
22962 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
22963 !               gg(1),gg(2),"rozne"
22964        DO k = 1, 3
22965         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
22966         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
22967         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
22968         gvdwx_scbase(k,i)= gvdwx_scbase(k,i) - gg(k)   &
22969                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
22970                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
22971         gvdwx_scbase(k,j)= gvdwx_scbase(k,j) + gg(k)  &
22972                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
22973                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
22974         gvdwc_scbase(k,i)=gvdwc_scbase(k,i)-gg(k)
22975         gvdwc_scbase(k,j)=gvdwc_scbase(k,j)+gg(k)
22976        END DO
22977        RETURN
22978       END SUBROUTINE sc_grad_scbase
22979
22980
22981       subroutine epep_sc_base(epepbase)
22982       use calc_data
22983       logical :: lprn
22984 !el local variables
22985       integer :: iint,itypi,itypi1,itypj,subchap
22986       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
22987       real(kind=8) :: evdw,sig0ij
22988       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
22989                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
22990                     sslipi,sslipj,faclip
22991       integer :: ii
22992       real(kind=8) :: fracinbuf
22993        real (kind=8) :: epepbase
22994        real (kind=8),dimension(4):: ener
22995        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
22996        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
22997         sqom1,sqom2,sqom12,c1,c2,c3,pom,Lambf,sparrow,&
22998         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
22999         dFdOM2,w1,w2,w3,dGCLdR,dFdL,dFdOM12,dbot ,&
23000         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23001         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23002         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1
23003        real(kind=8),dimension(3,2)::chead,erhead_tail
23004        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23005        integer troll
23006        eps_out=80.0d0
23007        epepbase=0.0d0
23008 !       do i=1,nres_molec(1)-1
23009         do i=ibond_start,ibond_end
23010         if (itype(i,1).eq.ntyp1_molec(1).or.itype(i+1,1).eq.ntyp1_molec(1)) cycle
23011 !C        itypi  = itype(i,1)
23012         dxi    = dc_norm(1,i)
23013         dyi    = dc_norm(2,i)
23014         dzi    = dc_norm(3,i)
23015 !        print *,dxi,(-c(1,i)+c(1,i+1))*vbld_inv(i+1)
23016         dsci_inv = vbld_inv(i+1)/2.0
23017         xi=(c(1,i)+c(1,i+1))/2.0
23018         yi=(c(2,i)+c(2,i+1))/2.0
23019         zi=(c(3,i)+c(3,i+1))/2.0
23020         xi=mod(xi,boxxsize)
23021          if (xi.lt.0) xi=xi+boxxsize
23022         yi=mod(yi,boxysize)
23023          if (yi.lt.0) yi=yi+boxysize
23024         zi=mod(zi,boxzsize)
23025          if (zi.lt.0) zi=zi+boxzsize
23026          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)
23027            itypj= itype(j,2)
23028            if (itype(j,2).eq.ntyp1_molec(2))cycle
23029            xj=c(1,j+nres)
23030            yj=c(2,j+nres)
23031            zj=c(3,j+nres)
23032            xj=dmod(xj,boxxsize)
23033            if (xj.lt.0) xj=xj+boxxsize
23034            yj=dmod(yj,boxysize)
23035            if (yj.lt.0) yj=yj+boxysize
23036            zj=dmod(zj,boxzsize)
23037            if (zj.lt.0) zj=zj+boxzsize
23038           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23039           xj_safe=xj
23040           yj_safe=yj
23041           zj_safe=zj
23042           subchap=0
23043
23044           do xshift=-1,1
23045           do yshift=-1,1
23046           do zshift=-1,1
23047           xj=xj_safe+xshift*boxxsize
23048           yj=yj_safe+yshift*boxysize
23049           zj=zj_safe+zshift*boxzsize
23050           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23051           if(dist_temp.lt.dist_init) then
23052             dist_init=dist_temp
23053             xj_temp=xj
23054             yj_temp=yj
23055             zj_temp=zj
23056             subchap=1
23057           endif
23058           enddo
23059           enddo
23060           enddo
23061           if (subchap.eq.1) then
23062           xj=xj_temp-xi
23063           yj=yj_temp-yi
23064           zj=zj_temp-zi
23065           else
23066           xj=xj_safe-xi
23067           yj=yj_safe-yi
23068           zj=zj_safe-zi
23069           endif
23070           dxj = dc_norm( 1, nres+j )
23071           dyj = dc_norm( 2, nres+j )
23072           dzj = dc_norm( 3, nres+j )
23073 !          d1i = dhead_scbasei(itypi) !this is shift of dipole/charge
23074 !          d1j = dhead_scbasej(itypi) !this is shift of dipole/charge
23075
23076 ! Gay-berne var's
23077           sig0ij = sigma_pepbase(itypj )
23078           chi1   = chi_pepbase(itypj,1 )
23079           chi2   = chi_pepbase(itypj,2 )
23080 !          chi1=0.0d0
23081 !          chi2=0.0d0
23082           chi12  = chi1 * chi2
23083           chip1  = chipp_pepbase(itypj,1 )
23084           chip2  = chipp_pepbase(itypj,2 )
23085 !          chip1=0.0d0
23086 !          chip2=0.0d0
23087           chip12 = chip1 * chip2
23088           chis1 = chis_pepbase(itypj,1)
23089           chis2 = chis_pepbase(itypj,2)
23090           chis12 = chis1 * chis2
23091           sig1 = sigmap1_pepbase(itypj)
23092           sig2 = sigmap2_pepbase(itypj)
23093 !       write (*,*) "sig1 = ", sig1
23094 !       write (*,*) "sig2 = ", sig2
23095        DO k = 1,3
23096 ! location of polar head is computed by taking hydrophobic centre
23097 ! and moving by a d1 * dc_norm vector
23098 ! see unres publications for very informative images
23099         chead(k,1) = (c(k,i)+c(k,i+1))/2.0
23100 ! + d1i * dc_norm(k, i+nres)
23101         chead(k,2) = c(k, j+nres)
23102 ! + d1j * dc_norm(k, j+nres)
23103 ! distance
23104 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23105 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23106         Rhead_distance(k) = chead(k,2) - chead(k,1)
23107 !        print *,gvdwc_pepbase(k,i)
23108
23109        END DO
23110        Rhead = dsqrt( &
23111           (Rhead_distance(1)*Rhead_distance(1)) &
23112         + (Rhead_distance(2)*Rhead_distance(2)) &
23113         + (Rhead_distance(3)*Rhead_distance(3)))
23114
23115 ! alpha factors from Fcav/Gcav
23116           b1 = alphasur_pepbase(1,itypj)
23117 !          b1=0.0d0
23118           b2 = alphasur_pepbase(2,itypj)
23119           b3 = alphasur_pepbase(3,itypj)
23120           b4 = alphasur_pepbase(4,itypj)
23121           alf1   = 0.0d0
23122           alf2   = 0.0d0
23123           alf12  = 0.0d0
23124           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23125 !          print *,i,j,rrij
23126           rij  = dsqrt(rrij)
23127 !----------------------------
23128        evdwij = 0.0d0
23129        ECL = 0.0d0
23130        Elj = 0.0d0
23131        Equad = 0.0d0
23132        Epol = 0.0d0
23133        Fcav=0.0d0
23134        eheadtail = 0.0d0
23135        dGCLdOM1 = 0.0d0
23136        dGCLdOM2 = 0.0d0
23137        dGCLdOM12 = 0.0d0
23138        dPOLdOM1 = 0.0d0
23139        dPOLdOM2 = 0.0d0
23140           Fcav = 0.0d0
23141           dFdR = 0.0d0
23142           dCAVdOM1  = 0.0d0
23143           dCAVdOM2  = 0.0d0
23144           dCAVdOM12 = 0.0d0
23145           dscj_inv = vbld_inv(j+nres)
23146           CALL sc_angular
23147 ! this should be in elgrad_init but om's are calculated by sc_angular
23148 ! which in turn is used by older potentials
23149 ! om = omega, sqom = om^2
23150           sqom1  = om1 * om1
23151           sqom2  = om2 * om2
23152           sqom12 = om12 * om12
23153
23154 ! now we calculate EGB - Gey-Berne
23155 ! It will be summed up in evdwij and saved in evdw
23156           sigsq     = 1.0D0  / sigsq
23157           sig       = sig0ij * dsqrt(sigsq)
23158           rij_shift = 1.0/rij - sig + sig0ij
23159           IF (rij_shift.le.0.0D0) THEN
23160            evdw = 1.0D20
23161            RETURN
23162           END IF
23163           sigder = -sig * sigsq
23164           rij_shift = 1.0D0 / rij_shift
23165           fac       = rij_shift**expon
23166           c1        = fac  * fac * aa_pepbase(itypj)
23167 !          c1        = 0.0d0
23168           c2        = fac  * bb_pepbase(itypj)
23169 !          c2        = 0.0d0
23170           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23171           eps2der   = eps3rt * evdwij
23172           eps3der   = eps2rt * evdwij
23173 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23174           evdwij    = eps2rt * eps3rt * evdwij
23175           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23176           fac    = -expon * (c1 + evdwij) * rij_shift
23177           sigder = fac * sigder
23178 !          fac    = rij * fac
23179 ! Calculate distance derivative
23180           gg(1) =  fac
23181           gg(2) =  fac
23182           gg(3) =  fac
23183           fac = chis1 * sqom1 + chis2 * sqom2 &
23184           - 2.0d0 * chis12 * om1 * om2 * om12
23185 ! we will use pom later in Gcav, so dont mess with it!
23186           pom = 1.0d0 - chis1 * chis2 * sqom12
23187           Lambf = (1.0d0 - (fac / pom))
23188           Lambf = dsqrt(Lambf)
23189           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23190 !       write (*,*) "sparrow = ", sparrow
23191           Chif = 1.0d0/rij * sparrow
23192           ChiLambf = Chif * Lambf
23193           eagle = dsqrt(ChiLambf)
23194           bat = ChiLambf ** 11.0d0
23195           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23196           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23197           botsq = bot * bot
23198           Fcav = top / bot
23199 !          print *,i,j,Fcav
23200           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23201           dbot = 12.0d0 * b4 * bat * Lambf
23202           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23203 !       dFdR = 0.0d0
23204 !      write (*,*) "dFcav/dR = ", dFdR
23205           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23206           dbot = 12.0d0 * b4 * bat * Chif
23207           eagle = Lambf * pom
23208           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23209           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23210           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23211               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23212
23213           dFdL = ((dtop * bot - top * dbot) / botsq)
23214 !       dFdL = 0.0d0
23215           dCAVdOM1  = dFdL * ( dFdOM1 )
23216           dCAVdOM2  = dFdL * ( dFdOM2 )
23217           dCAVdOM12 = dFdL * ( dFdOM12 )
23218
23219           ertail(1) = xj*rij
23220           ertail(2) = yj*rij
23221           ertail(3) = zj*rij
23222        DO k = 1, 3
23223 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23224 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23225         pom = ertail(k)
23226 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23227         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
23228                   - (( dFdR + gg(k) ) * pom)/2.0
23229 !        print *,gvdwc_pepbase(k,i),i,(( dFdR + gg(k) ) * pom)/2.0
23230 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23231 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23232 !     &             - ( dFdR * pom )
23233         pom = ertail(k)
23234 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23235         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
23236                   + (( dFdR + gg(k) ) * pom)
23237 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23238 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23239 !c!     &             + ( dFdR * pom )
23240
23241         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
23242                   - (( dFdR + gg(k) ) * ertail(k))/2.0
23243 !        print *,gvdwc_pepbase(k,i+1),i+1,(( dFdR + gg(k) ) * pom)/2.0
23244
23245 !c!     &             - ( dFdR * ertail(k))
23246
23247         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
23248                   + (( dFdR + gg(k) ) * ertail(k))
23249 !c!     &             + ( dFdR * ertail(k))
23250
23251         gg(k) = 0.0d0
23252 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23253 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23254       END DO
23255
23256
23257        w1 = wdipdip_pepbase(1,itypj)
23258        w2 = -wdipdip_pepbase(3,itypj)/2.0
23259        w3 = wdipdip_pepbase(2,itypj)
23260 !       w1=0.0d0
23261 !       w2=0.0d0
23262 !c!-------------------------------------------------------------------
23263 !c! ECL
23264 !       w3=0.0d0
23265        fac = (om12 - 3.0d0 * om1 * om2)
23266        c1 = (w1 / (Rhead**3.0d0)) * fac
23267        c2 = (w2 / Rhead ** 6.0d0)  &
23268          * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
23269        c3= (w3/ Rhead ** 6.0d0)  &
23270          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23271
23272        ECL = c1 - c2 + c3
23273
23274        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
23275        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
23276          * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
23277        c3=  (-6.0d0 * w3) / (Rhead ** 7.0d0) &
23278          * (2.0d0 - 2.0d0*fac*fac +3.0d0*(sqom1 + sqom2))
23279
23280        dGCLdR = c1 - c2 + c3
23281 !c! dECL/dom1
23282        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
23283        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23284          * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
23285        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om1-2.0d0*(fac)*(-om2))
23286        dGCLdOM1 = c1 - c2 + c3
23287 !c! dECL/dom2
23288        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
23289        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
23290          * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
23291        c3 =(6.0d0*w3/ Rhead ** 6.0d0)*(om2-2.0d0*(fac)*(-om1))
23292
23293        dGCLdOM2 = c1 - c2 + c3
23294 !c! dECL/dom12
23295        c1 = w1 / (Rhead ** 3.0d0)
23296        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
23297        c3 = (w3/ Rhead ** 6.0d0)*(-4.0d0*fac)
23298        dGCLdOM12 = c1 - c2 + c3
23299        DO k= 1, 3
23300         erhead(k) = Rhead_distance(k)/Rhead
23301        END DO
23302        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23303        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
23304 !       facd1 = d1 * vbld_inv(i+nres)
23305 !       facd2 = d2 * vbld_inv(j+nres)
23306        DO k = 1, 3
23307
23308 !        pom = erhead(k)
23309 !+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23310 !        gvdwx_pepbase(k,i) = gvdwx_scbase(k,i) &
23311 !                  - dGCLdR * pom
23312         pom = erhead(k)
23313 !+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
23314         gvdwx_pepbase(k,j) = gvdwx_pepbase(k,j) &
23315                   + dGCLdR * pom
23316
23317         gvdwc_pepbase(k,i) = gvdwc_pepbase(k,i) &
23318                   - dGCLdR * erhead(k)/2.0d0
23319 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
23320         gvdwc_pepbase(k,i+1) = gvdwc_pepbase(k,i+1) &
23321                   - dGCLdR * erhead(k)/2.0d0
23322 !        print *,gvdwc_pepbase(k,i+1),i+1,- dGCLdR * erhead(k)/2.0d0
23323         gvdwc_pepbase(k,j) = gvdwc_pepbase(k,j) &
23324                   + dGCLdR * erhead(k)
23325        END DO
23326 !       print *,i,j,evdwij,Fcav,ECL,"vdw,cav,ecl"
23327        epepbase=epepbase+evdwij+Fcav+ECL
23328        call sc_grad_pepbase
23329        enddo
23330        enddo
23331       END SUBROUTINE epep_sc_base
23332       SUBROUTINE sc_grad_pepbase
23333       use calc_data
23334
23335        real (kind=8) :: dcosom1(3),dcosom2(3)
23336        eom1  =    &
23337               eps2der * eps2rt_om1   &
23338             - 2.0D0 * alf1 * eps3der &
23339             + sigder * sigsq_om1     &
23340             + dCAVdOM1               &
23341             + dGCLdOM1               &
23342             + dPOLdOM1
23343
23344        eom2  =  &
23345               eps2der * eps2rt_om2   &
23346             + 2.0D0 * alf2 * eps3der &
23347             + sigder * sigsq_om2     &
23348             + dCAVdOM2               &
23349             + dGCLdOM2               &
23350             + dPOLdOM2
23351
23352        eom12 =    &
23353               evdwij  * eps1_om12     &
23354             + eps2der * eps2rt_om12   &
23355             - 2.0D0 * alf12 * eps3der &
23356             + sigder *sigsq_om12      &
23357             + dCAVdOM12               &
23358             + dGCLdOM12
23359 !        om12=0.0
23360 !        eom12=0.0
23361 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23362 !        if (i.eq.30) print *,gvdwc_pepbase(k,i),- gg(k),&
23363 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23364 !                 *dsci_inv*2.0
23365 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23366 !               gg(1),gg(2),"rozne"
23367        DO k = 1, 3
23368         dcosom1(k) = rij * (dc_norm(k,i) - om1 * erij(k))
23369         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
23370         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23371         gvdwc_pepbase(k,i)= gvdwc_pepbase(k,i) +0.5*(- gg(k))   &
23372                  + (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23373                  *dsci_inv*2.0 &
23374                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
23375         gvdwc_pepbase(k,i+1)= gvdwc_pepbase(k,i+1) +0.5*(- gg(k))   &
23376                  - (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i))) &
23377                  *dsci_inv*2.0 &
23378                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
23379 !         print *,eom12,eom2,om12,om2
23380 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
23381 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
23382         gvdwx_pepbase(k,j)= gvdwx_pepbase(k,j) + gg(k)  &
23383                  + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
23384                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23385         gvdwc_pepbase(k,j)=gvdwc_pepbase(k,j)+gg(k)
23386        END DO
23387        RETURN
23388       END SUBROUTINE sc_grad_pepbase
23389       subroutine eprot_sc_phosphate(escpho)
23390       use calc_data
23391 !      implicit real*8 (a-h,o-z)
23392 !      include 'DIMENSIONS'
23393 !      include 'COMMON.GEO'
23394 !      include 'COMMON.VAR'
23395 !      include 'COMMON.LOCAL'
23396 !      include 'COMMON.CHAIN'
23397 !      include 'COMMON.DERIV'
23398 !      include 'COMMON.NAMES'
23399 !      include 'COMMON.INTERACT'
23400 !      include 'COMMON.IOUNITS'
23401 !      include 'COMMON.CALC'
23402 !      include 'COMMON.CONTROL'
23403 !      include 'COMMON.SBRIDGE'
23404       logical :: lprn
23405 !el local variables
23406       integer :: iint,itypi,itypi1,itypj,subchap
23407       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23408       real(kind=8) :: evdw,sig0ij
23409       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23410                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23411                     sslipi,sslipj,faclip,alpha_sco
23412       integer :: ii
23413       real(kind=8) :: fracinbuf
23414        real (kind=8) :: escpho
23415        real (kind=8),dimension(4):: ener
23416        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23417        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23418         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
23419         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23420         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
23421         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23422         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23423         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
23424        real(kind=8),dimension(3,2)::chead,erhead_tail
23425        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23426        integer troll
23427        eps_out=80.0d0
23428        escpho=0.0d0
23429 !       do i=1,nres_molec(1)
23430         do i=ibond_start,ibond_end
23431         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23432         itypi  = itype(i,1)
23433         dxi    = dc_norm(1,nres+i)
23434         dyi    = dc_norm(2,nres+i)
23435         dzi    = dc_norm(3,nres+i)
23436         dsci_inv = vbld_inv(i+nres)
23437         xi=c(1,nres+i)
23438         yi=c(2,nres+i)
23439         zi=c(3,nres+i)
23440         xi=mod(xi,boxxsize)
23441          if (xi.lt.0) xi=xi+boxxsize
23442         yi=mod(yi,boxysize)
23443          if (yi.lt.0) yi=yi+boxysize
23444         zi=mod(zi,boxzsize)
23445          if (zi.lt.0) zi=zi+boxzsize
23446          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
23447            itypj= itype(j,2)
23448            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
23449             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
23450            xj=(c(1,j)+c(1,j+1))/2.0
23451            yj=(c(2,j)+c(2,j+1))/2.0
23452            zj=(c(3,j)+c(3,j+1))/2.0
23453            xj=dmod(xj,boxxsize)
23454            if (xj.lt.0) xj=xj+boxxsize
23455            yj=dmod(yj,boxysize)
23456            if (yj.lt.0) yj=yj+boxysize
23457            zj=dmod(zj,boxzsize)
23458            if (zj.lt.0) zj=zj+boxzsize
23459           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23460           xj_safe=xj
23461           yj_safe=yj
23462           zj_safe=zj
23463           subchap=0
23464           do xshift=-1,1
23465           do yshift=-1,1
23466           do zshift=-1,1
23467           xj=xj_safe+xshift*boxxsize
23468           yj=yj_safe+yshift*boxysize
23469           zj=zj_safe+zshift*boxzsize
23470           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23471           if(dist_temp.lt.dist_init) then
23472             dist_init=dist_temp
23473             xj_temp=xj
23474             yj_temp=yj
23475             zj_temp=zj
23476             subchap=1
23477           endif
23478           enddo
23479           enddo
23480           enddo
23481           if (subchap.eq.1) then
23482           xj=xj_temp-xi
23483           yj=yj_temp-yi
23484           zj=zj_temp-zi
23485           else
23486           xj=xj_safe-xi
23487           yj=yj_safe-yi
23488           zj=zj_safe-zi
23489           endif
23490           dxj = dc_norm( 1,j )
23491           dyj = dc_norm( 2,j )
23492           dzj = dc_norm( 3,j )
23493           dscj_inv = vbld_inv(j+1)
23494
23495 ! Gay-berne var's
23496           sig0ij = sigma_scpho(itypi )
23497           chi1   = chi_scpho(itypi,1 )
23498           chi2   = chi_scpho(itypi,2 )
23499 !          chi1=0.0d0
23500 !          chi2=0.0d0
23501           chi12  = chi1 * chi2
23502           chip1  = chipp_scpho(itypi,1 )
23503           chip2  = chipp_scpho(itypi,2 )
23504 !          chip1=0.0d0
23505 !          chip2=0.0d0
23506           chip12 = chip1 * chip2
23507           chis1 = chis_scpho(itypi,1)
23508           chis2 = chis_scpho(itypi,2)
23509           chis12 = chis1 * chis2
23510           sig1 = sigmap1_scpho(itypi)
23511           sig2 = sigmap2_scpho(itypi)
23512 !       write (*,*) "sig1 = ", sig1
23513 !       write (*,*) "sig1 = ", sig1
23514 !       write (*,*) "sig2 = ", sig2
23515 ! alpha factors from Fcav/Gcav
23516           alf1   = 0.0d0
23517           alf2   = 0.0d0
23518           alf12  = 0.0d0
23519           a12sq = rborn_scphoi(itypi) * rborn_scphoj(itypi)
23520
23521           b1 = alphasur_scpho(1,itypi)
23522 !          b1=0.0d0
23523           b2 = alphasur_scpho(2,itypi)
23524           b3 = alphasur_scpho(3,itypi)
23525           b4 = alphasur_scpho(4,itypi)
23526 ! used to determine whether we want to do quadrupole calculations
23527 ! used by Fgb
23528        eps_in = epsintab_scpho(itypi)
23529        if (eps_in.eq.0.0) eps_in=1.0
23530        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
23531 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
23532 !-------------------------------------------------------------------
23533 ! tail location and distance calculations
23534           d1i = dhead_scphoi(itypi) !this is shift of dipole/charge
23535           d1j = 0.0
23536        DO k = 1,3
23537 ! location of polar head is computed by taking hydrophobic centre
23538 ! and moving by a d1 * dc_norm vector
23539 ! see unres publications for very informative images
23540         chead(k,1) = c(k, i+nres) + d1i * dc_norm(k, i+nres)
23541         chead(k,2) = (c(k, j) + c(k, j+1))/2.0
23542 ! distance
23543 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
23544 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
23545         Rhead_distance(k) = chead(k,2) - chead(k,1)
23546        END DO
23547 ! pitagoras (root of sum of squares)
23548        Rhead = dsqrt( &
23549           (Rhead_distance(1)*Rhead_distance(1)) &
23550         + (Rhead_distance(2)*Rhead_distance(2)) &
23551         + (Rhead_distance(3)*Rhead_distance(3)))
23552        Rhead_sq=Rhead**2.0
23553 !-------------------------------------------------------------------
23554 ! zero everything that should be zero'ed
23555        evdwij = 0.0d0
23556        ECL = 0.0d0
23557        Elj = 0.0d0
23558        Equad = 0.0d0
23559        Epol = 0.0d0
23560        Fcav=0.0d0
23561        eheadtail = 0.0d0
23562        dGCLdR=0.0d0
23563        dGCLdOM1 = 0.0d0
23564        dGCLdOM2 = 0.0d0
23565        dGCLdOM12 = 0.0d0
23566        dPOLdOM1 = 0.0d0
23567        dPOLdOM2 = 0.0d0
23568           Fcav = 0.0d0
23569           dFdR = 0.0d0
23570           dCAVdOM1  = 0.0d0
23571           dCAVdOM2  = 0.0d0
23572           dCAVdOM12 = 0.0d0
23573           dscj_inv = vbld_inv(j+1)/2.0
23574 !dhead_scbasej(itypi,itypj)
23575 !          print *,i,j,dscj_inv,dsci_inv
23576 ! rij holds 1/(distance of Calpha atoms)
23577           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
23578           rij  = dsqrt(rrij)
23579 !----------------------------
23580           CALL sc_angular
23581 ! this should be in elgrad_init but om's are calculated by sc_angular
23582 ! which in turn is used by older potentials
23583 ! om = omega, sqom = om^2
23584           sqom1  = om1 * om1
23585           sqom2  = om2 * om2
23586           sqom12 = om12 * om12
23587
23588 ! now we calculate EGB - Gey-Berne
23589 ! It will be summed up in evdwij and saved in evdw
23590           sigsq     = 1.0D0  / sigsq
23591           sig       = sig0ij * dsqrt(sigsq)
23592 !          rij_shift = 1.0D0  / rij - sig + sig0ij
23593           rij_shift = 1.0/rij - sig + sig0ij
23594           IF (rij_shift.le.0.0D0) THEN
23595            evdw = 1.0D20
23596            RETURN
23597           END IF
23598           sigder = -sig * sigsq
23599           rij_shift = 1.0D0 / rij_shift
23600           fac       = rij_shift**expon
23601           c1        = fac  * fac * aa_scpho(itypi)
23602 !          c1        = 0.0d0
23603           c2        = fac  * bb_scpho(itypi)
23604 !          c2        = 0.0d0
23605           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
23606           eps2der   = eps3rt * evdwij
23607           eps3der   = eps2rt * evdwij
23608 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
23609           evdwij    = eps2rt * eps3rt * evdwij
23610           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
23611           fac    = -expon * (c1 + evdwij) * rij_shift
23612           sigder = fac * sigder
23613 !          fac    = rij * fac
23614 ! Calculate distance derivative
23615           gg(1) =  fac
23616           gg(2) =  fac
23617           gg(3) =  fac
23618           fac = chis1 * sqom1 + chis2 * sqom2 &
23619           - 2.0d0 * chis12 * om1 * om2 * om12
23620 ! we will use pom later in Gcav, so dont mess with it!
23621           pom = 1.0d0 - chis1 * chis2 * sqom12
23622           Lambf = (1.0d0 - (fac / pom))
23623           Lambf = dsqrt(Lambf)
23624           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
23625 !       write (*,*) "sparrow = ", sparrow
23626           Chif = 1.0d0/rij * sparrow
23627           ChiLambf = Chif * Lambf
23628           eagle = dsqrt(ChiLambf)
23629           bat = ChiLambf ** 11.0d0
23630           top = b1 * ( eagle + b2 * ChiLambf - b3 )
23631           bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
23632           botsq = bot * bot
23633           Fcav = top / bot
23634           dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
23635           dbot = 12.0d0 * b4 * bat * Lambf
23636           dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
23637 !       dFdR = 0.0d0
23638 !      write (*,*) "dFcav/dR = ", dFdR
23639           dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
23640           dbot = 12.0d0 * b4 * bat * Chif
23641           eagle = Lambf * pom
23642           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
23643           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
23644           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
23645               * (chis2 * om2 * om12 - om1) / (eagle * pom)
23646
23647           dFdL = ((dtop * bot - top * dbot) / botsq)
23648 !       dFdL = 0.0d0
23649           dCAVdOM1  = dFdL * ( dFdOM1 )
23650           dCAVdOM2  = dFdL * ( dFdOM2 )
23651           dCAVdOM12 = dFdL * ( dFdOM12 )
23652
23653           ertail(1) = xj*rij
23654           ertail(2) = yj*rij
23655           ertail(3) = zj*rij
23656        DO k = 1, 3
23657 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23658 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23659 !         if (i.eq.3) print *,'decl0',gvdwx_scpho(k,i),i
23660
23661         pom = ertail(k)
23662 !        print *,pom,gg(k),dFdR
23663 !-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
23664         gvdwx_scpho(k,i) = gvdwx_scpho(k,i) &
23665                   - (( dFdR + gg(k) ) * pom)
23666 !                 +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i)) &
23667 !                 +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23668 !     &             - ( dFdR * pom )
23669 !        pom = ertail(k)
23670 !-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
23671 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j) &
23672 !                  + (( dFdR + gg(k) ) * pom)
23673 !                 +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
23674 !                 +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23675 !c!     &             + ( dFdR * pom )
23676
23677         gvdwc_scpho(k,i) = gvdwc_scpho(k,i) &
23678                   - (( dFdR + gg(k) ) * ertail(k))
23679 !c!     &             - ( dFdR * ertail(k))
23680
23681         gvdwc_scpho(k,j) = gvdwc_scpho(k,j) &
23682                   + (( dFdR + gg(k) ) * ertail(k))/2.0
23683
23684         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1) &
23685                   + (( dFdR + gg(k) ) * ertail(k))/2.0
23686
23687 !c!     &             + ( dFdR * ertail(k))
23688
23689         gg(k) = 0.0d0
23690         ENDDO
23691 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
23692 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
23693 !      alphapol1 = alphapol_scpho(itypi)
23694        if (wqq_scpho(itypi).ne.0.0) then
23695        Qij=wqq_scpho(itypi)/eps_in
23696        alpha_sco=1.d0/alphi_scpho(itypi)
23697 !       Qij=0.0
23698        Ecl = (332.0d0 * Qij*dexp(-Rhead*alpha_sco)) / Rhead
23699 !c! derivative of Ecl is Gcl...
23700        dGCLdR = (-332.0d0 * Qij*dexp(-Rhead*alpha_sco)*  &
23701                 (Rhead*alpha_sco+1) ) / Rhead_sq
23702        if (energy_dec) write(iout,*) "ECL",ECL,Rhead,1.0/rij
23703        else if (wqdip_scpho(2,itypi).gt.0.0d0) then
23704        w1        = wqdip_scpho(1,itypi)
23705        w2        = wqdip_scpho(2,itypi)
23706 !       w1=0.0d0
23707 !       w2=0.0d0
23708 !       pis       = sig0head_scbase(itypi,itypj)
23709 !       eps_head   = epshead_scbase(itypi,itypj)
23710 !c!-------------------------------------------------------------------
23711
23712 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
23713 !c!     &        +dhead(1,1,itypi,itypj))**2))
23714 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
23715 !c!     &        +dhead(2,1,itypi,itypj))**2))
23716
23717 !c!-------------------------------------------------------------------
23718 !c! ecl
23719        sparrow  = w1  *  om1
23720        hawk     = w2 *  (1.0d0 - sqom2)
23721        Ecl = sparrow / Rhead**2.0d0 &
23722            - hawk    / Rhead**4.0d0
23723 !c!-------------------------------------------------------------------
23724        if (energy_dec) write(iout,*) "ECLdipdip",ECL,Rhead,&
23725            1.0/rij,sparrow
23726
23727 !c! derivative of ecl is Gcl
23728 !c! dF/dr part
23729        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
23730                 + 4.0d0 * hawk    / Rhead**5.0d0
23731 !c! dF/dom1
23732        dGCLdOM1 = (w1) / (Rhead**2.0d0)
23733 !c! dF/dom2
23734        dGCLdOM2 = (2.0d0 * w2 * om2) / (Rhead ** 4.0d0)
23735        endif
23736
23737 !c--------------------------------------------------------------------
23738 !c Polarization energy
23739 !c Epol
23740        R1 = 0.0d0
23741        DO k = 1, 3
23742 !c! Calculate head-to-tail distances tail is center of side-chain
23743         R1=R1+((c(k,j)+c(k,j+1))/2.0-chead(k,1))**2
23744        END DO
23745 !c! Pitagoras
23746        R1 = dsqrt(R1)
23747
23748       alphapol1 = alphapol_scpho(itypi)
23749 !      alphapol1=0.0
23750        MomoFac1 = (1.0d0 - chi2 * sqom1)
23751        RR1  = R1 * R1 / MomoFac1
23752        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
23753 !       print *,"ee1",ee1,a12sq,alphapol1,eps_inout_fac
23754        fgb1 = sqrt( RR1 + a12sq * ee1)
23755 !       eps_inout_fac=0.0d0
23756        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
23757 ! derivative of Epol is Gpol...
23758        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
23759                 / (fgb1 ** 5.0d0)
23760        dFGBdR1 = ( (R1 / MomoFac1) &
23761              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
23762              / ( 2.0d0 * fgb1 )
23763        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
23764                * (2.0d0 - 0.5d0 * ee1) ) &
23765                / (2.0d0 * fgb1)
23766        dPOLdR1 = dPOLdFGB1 * dFGBdR1
23767 !       dPOLdR1 = 0.0d0
23768 !       dPOLdOM1 = 0.0d0
23769        dFGBdOM1 = (((R1 * R1 * chi2 * om1) / (MomoFac1 * MomoFac1)) &
23770                * (2.0d0 - 0.5d0 * ee1) ) &
23771                / (2.0d0 * fgb1)
23772
23773        dPOLdOM1 = dPOLdFGB1 * dFGBdOM1
23774        dPOLdOM2 = 0.0
23775        DO k = 1, 3
23776         erhead(k) = Rhead_distance(k)/Rhead
23777         erhead_tail(k,1) = (((c(k,j)+c(k,j+1))/2.0-chead(k,1))/R1)
23778        END DO
23779
23780        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
23781        erdxj = scalar( erhead(1), dC_norm(1,j) )
23782        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
23783 !       bat=0.0d0
23784        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j))
23785        facd1 = d1i * vbld_inv(i+nres)
23786        facd2 = d1j * vbld_inv(j)
23787 !       facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
23788
23789        DO k = 1, 3
23790         hawk = (erhead_tail(k,1) + &
23791         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
23792 !        facd1=0.0d0
23793 !        facd2=0.0d0
23794 !         if (i.eq.3) print *,'decl1',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i,&
23795 !                pom,(erhead_tail(k,1))
23796
23797 !        print *,'decl',dGCLdR,dPOLdR1,gvdwc_scpho(k,i)
23798         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
23799         gvdwx_scpho(k,i) = gvdwx_scpho(k,i)   &
23800                    - dGCLdR * pom &
23801                    - dPOLdR1 *  (erhead_tail(k,1))
23802 !     &             - dGLJdR * pom
23803
23804         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j))
23805 !        gvdwx_scpho(k,j) = gvdwx_scpho(k,j)    &
23806 !                   + dGCLdR * pom  &
23807 !                   + dPOLdR1 * (erhead_tail(k,1))
23808 !     &             + dGLJdR * pom
23809
23810
23811         gvdwc_scpho(k,i) = gvdwc_scpho(k,i)  &
23812                   - dGCLdR * erhead(k) &
23813                   - dPOLdR1 * erhead_tail(k,1)
23814 !     &             - dGLJdR * erhead(k)
23815
23816         gvdwc_scpho(k,j) = gvdwc_scpho(k,j)         &
23817                   + (dGCLdR * erhead(k)  &
23818                   + dPOLdR1 * erhead_tail(k,1))/2.0
23819         gvdwc_scpho(k,j+1) = gvdwc_scpho(k,j+1)         &
23820                   + (dGCLdR * erhead(k)  &
23821                   + dPOLdR1 * erhead_tail(k,1))/2.0
23822
23823 !     &             + dGLJdR * erhead(k)
23824 !        if (i.eq.3) print *,'decl2',dGCLdR,dPOLdR1,gvdwc_scpho(k,i),i
23825
23826        END DO
23827 !       if (i.eq.3) print *,i,j,evdwij,epol,Fcav,ECL
23828        if (energy_dec) write (iout,'(a22,2i5,4f8.3,f16.3)'), &
23829         "escpho:evdw,pol,cav,CL",i,j,evdwij,epol,Fcav,ECL,escpho
23830        escpho=escpho+evdwij+epol+Fcav+ECL
23831        call sc_grad_scpho
23832          enddo
23833
23834       enddo
23835
23836       return
23837       end subroutine eprot_sc_phosphate
23838       SUBROUTINE sc_grad_scpho
23839       use calc_data
23840
23841        real (kind=8) :: dcosom1(3),dcosom2(3)
23842        eom1  =    &
23843               eps2der * eps2rt_om1   &
23844             - 2.0D0 * alf1 * eps3der &
23845             + sigder * sigsq_om1     &
23846             + dCAVdOM1               &
23847             + dGCLdOM1               &
23848             + dPOLdOM1
23849
23850        eom2  =  &
23851               eps2der * eps2rt_om2   &
23852             + 2.0D0 * alf2 * eps3der &
23853             + sigder * sigsq_om2     &
23854             + dCAVdOM2               &
23855             + dGCLdOM2               &
23856             + dPOLdOM2
23857
23858        eom12 =    &
23859               evdwij  * eps1_om12     &
23860             + eps2der * eps2rt_om12   &
23861             - 2.0D0 * alf12 * eps3der &
23862             + sigder *sigsq_om12      &
23863             + dCAVdOM12               &
23864             + dGCLdOM12
23865 !        om12=0.0
23866 !        eom12=0.0
23867 !       print *,eom1,eom2,eom12,om12,i,j,"eom1,2,12",erij(1),erij(2),erij(3)
23868 !        if (i.eq.30) print *,gvdwc_scpho(k,i),- gg(k),&
23869 !                 (-eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,i)))&
23870 !                 *dsci_inv*2.0
23871 !       print *,dsci_inv,dscj_inv,dc_norm(2,nres+j),dc_norm(2,nres+i),&
23872 !               gg(1),gg(2),"rozne"
23873        DO k = 1, 3
23874         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
23875         dcosom2(k) = rij * (dc_norm(k,j) - om2 * erij(k))
23876         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
23877         gvdwc_scpho(k,j)= gvdwc_scpho(k,j) +0.5*( gg(k))   &
23878                  + (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j)))&
23879                  *dscj_inv*2.0 &
23880                  - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
23881         gvdwc_scpho(k,j+1)= gvdwc_scpho(k,j+1) +0.5*( gg(k))   &
23882                  - (-eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,j))) &
23883                  *dscj_inv*2.0 &
23884                  + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
23885         gvdwx_scpho(k,i)= gvdwx_scpho(k,i) - gg(k)   &
23886                  + (eom12*(dc_norm(k,j)-om12*dc_norm(k,nres+i)) &
23887                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
23888
23889 !         print *,eom12,eom2,om12,om2
23890 !eom12*(-dc_norm(k,i)/2.0-om12*dc_norm(k,nres+j)),&
23891 !                (eom2*(erij(k)-om2*dc_norm(k,nres+j)))
23892 !        gvdwx_scpho(k,j)= gvdwx_scpho(k,j) + gg(k)  &
23893 !                 + (eom12*(dc_norm(k,i)-om12*dc_norm(k,nres+j))&
23894 !                 + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
23895         gvdwc_scpho(k,i)=gvdwc_scpho(k,i)-gg(k)
23896        END DO
23897        RETURN
23898       END SUBROUTINE sc_grad_scpho
23899       subroutine eprot_pep_phosphate(epeppho)
23900       use calc_data
23901 !      implicit real*8 (a-h,o-z)
23902 !      include 'DIMENSIONS'
23903 !      include 'COMMON.GEO'
23904 !      include 'COMMON.VAR'
23905 !      include 'COMMON.LOCAL'
23906 !      include 'COMMON.CHAIN'
23907 !      include 'COMMON.DERIV'
23908 !      include 'COMMON.NAMES'
23909 !      include 'COMMON.INTERACT'
23910 !      include 'COMMON.IOUNITS'
23911 !      include 'COMMON.CALC'
23912 !      include 'COMMON.CONTROL'
23913 !      include 'COMMON.SBRIDGE'
23914       logical :: lprn
23915 !el local variables
23916       integer :: iint,itypi,itypi1,itypj,subchap
23917       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,fac,e1,e2,sigm,epsi
23918       real(kind=8) :: evdw,sig0ij
23919       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
23920                     dist_temp, dist_init,aa,bb,ssgradlipi,ssgradlipj, &
23921                     sslipi,sslipj,faclip
23922       integer :: ii
23923       real(kind=8) :: fracinbuf
23924        real (kind=8) :: epeppho
23925        real (kind=8),dimension(4):: ener
23926        real(kind=8) :: b1,b2,b3,b4,egb,eps_in,eps_inout_fac,eps_out
23927        real(kind=8) :: ECL,Elj,Equad,Epol,eheadtail,rhead,dGCLOM2,&
23928         sqom1,sqom2,sqom12,c1,c2,pom,Lambf,sparrow,&
23929         Chif,ChiLambf,bat,eagle,top,bot,botsq,Fcav,dtop,dFdR,dFdOM1,&
23930         dFdOM2,w1,w2,dGCLdR,dFdL,dFdOM12,dbot ,&
23931         r1,eps_head,alphapol1,pis,facd2,d2,facd1,d1,erdxj,erdxi,federmaus,&
23932         dPOLdR1,dFGBdOM2,dFGBdR1,dPOLdFGB1,RR1,MomoFac1,hawk,d1i,d1j,&
23933         sig1,sig2,chis12,chis2,ee1,fgb1,a12sq,chis1,Rhead_sq,Qij,dFGBdOM1
23934        real(kind=8),dimension(3,2)::chead,erhead_tail
23935        real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead
23936        integer troll
23937        real (kind=8) :: dcosom1(3),dcosom2(3)
23938        epeppho=0.0d0
23939 !       do i=1,nres_molec(1)
23940         do i=ibond_start,ibond_end
23941         if (itype(i,1).eq.ntyp1_molec(1)) cycle
23942         itypi  = itype(i,1)
23943         dsci_inv = vbld_inv(i+1)/2.0
23944         dxi    = dc_norm(1,i)
23945         dyi    = dc_norm(2,i)
23946         dzi    = dc_norm(3,i)
23947         xi=(c(1,i)+c(1,i+1))/2.0
23948         yi=(c(2,i)+c(2,i+1))/2.0
23949         zi=(c(3,i)+c(3,i+1))/2.0
23950         xi=mod(xi,boxxsize)
23951          if (xi.lt.0) xi=xi+boxxsize
23952         yi=mod(yi,boxysize)
23953          if (yi.lt.0) yi=yi+boxysize
23954         zi=mod(zi,boxzsize)
23955          if (zi.lt.0) zi=zi+boxzsize
23956          do j=nres_molec(1)+1,nres_molec(2)+nres_molec(1)-1
23957            itypj= itype(j,2)
23958            if ((itype(j,2).eq.ntyp1_molec(2)).or.&
23959             (itype(j+1,2).eq.ntyp1_molec(2))) cycle
23960            xj=(c(1,j)+c(1,j+1))/2.0
23961            yj=(c(2,j)+c(2,j+1))/2.0
23962            zj=(c(3,j)+c(3,j+1))/2.0
23963            xj=dmod(xj,boxxsize)
23964            if (xj.lt.0) xj=xj+boxxsize
23965            yj=dmod(yj,boxysize)
23966            if (yj.lt.0) yj=yj+boxysize
23967            zj=dmod(zj,boxzsize)
23968            if (zj.lt.0) zj=zj+boxzsize
23969           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23970           xj_safe=xj
23971           yj_safe=yj
23972           zj_safe=zj
23973           subchap=0
23974           do xshift=-1,1
23975           do yshift=-1,1
23976           do zshift=-1,1
23977           xj=xj_safe+xshift*boxxsize
23978           yj=yj_safe+yshift*boxysize
23979           zj=zj_safe+zshift*boxzsize
23980           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
23981           if(dist_temp.lt.dist_init) then
23982             dist_init=dist_temp
23983             xj_temp=xj
23984             yj_temp=yj
23985             zj_temp=zj
23986             subchap=1
23987           endif
23988           enddo
23989           enddo
23990           enddo
23991           if (subchap.eq.1) then
23992           xj=xj_temp-xi
23993           yj=yj_temp-yi
23994           zj=zj_temp-zi
23995           else
23996           xj=xj_safe-xi
23997           yj=yj_safe-yi
23998           zj=zj_safe-zi
23999           endif
24000           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24001           rij  = dsqrt(rrij)
24002           dxj = dc_norm( 1,j )
24003           dyj = dc_norm( 2,j )
24004           dzj = dc_norm( 3,j )
24005           dscj_inv = vbld_inv(j+1)/2.0
24006 ! Gay-berne var's
24007           sig0ij = sigma_peppho
24008 !          chi1=0.0d0
24009 !          chi2=0.0d0
24010           chi12  = chi1 * chi2
24011 !          chip1=0.0d0
24012 !          chip2=0.0d0
24013           chip12 = chip1 * chip2
24014 !          chis1 = 0.0d0
24015 !          chis2 = 0.0d0
24016           chis12 = chis1 * chis2
24017           sig1 = sigmap1_peppho
24018           sig2 = sigmap2_peppho
24019 !       write (*,*) "sig1 = ", sig1
24020 !       write (*,*) "sig1 = ", sig1
24021 !       write (*,*) "sig2 = ", sig2
24022 ! alpha factors from Fcav/Gcav
24023           alf1   = 0.0d0
24024           alf2   = 0.0d0
24025           alf12  = 0.0d0
24026           b1 = alphasur_peppho(1)
24027 !          b1=0.0d0
24028           b2 = alphasur_peppho(2)
24029           b3 = alphasur_peppho(3)
24030           b4 = alphasur_peppho(4)
24031           CALL sc_angular
24032        sqom1=om1*om1
24033        evdwij = 0.0d0
24034        ECL = 0.0d0
24035        Elj = 0.0d0
24036        Equad = 0.0d0
24037        Epol = 0.0d0
24038        Fcav=0.0d0
24039        eheadtail = 0.0d0
24040        dGCLdR=0.0d0
24041        dGCLdOM1 = 0.0d0
24042        dGCLdOM2 = 0.0d0
24043        dGCLdOM12 = 0.0d0
24044        dPOLdOM1 = 0.0d0
24045        dPOLdOM2 = 0.0d0
24046           Fcav = 0.0d0
24047           dFdR = 0.0d0
24048           dCAVdOM1  = 0.0d0
24049           dCAVdOM2  = 0.0d0
24050           dCAVdOM12 = 0.0d0
24051           rij_shift = rij
24052           fac       = rij_shift**expon
24053           c1        = fac  * fac * aa_peppho
24054 !          c1        = 0.0d0
24055           c2        = fac  * bb_peppho
24056 !          c2        = 0.0d0
24057           evdwij    =  c1 + c2
24058 ! Now cavity....................
24059        eagle = dsqrt(1.0/rij_shift)
24060        top = b1 * ( eagle + b2 * 1.0/rij_shift - b3 )
24061           bot = 1.0d0 + b4 * (1.0/rij_shift ** 12.0d0)
24062           botsq = bot * bot
24063           Fcav = top / bot
24064           dtop = b1 * ((1.0/ (2.0d0 * eagle)) + (b2))
24065           dbot = 12.0d0 * b4 * (1.0/rij_shift) ** 11.0d0
24066           dFdR = ((dtop * bot - top * dbot) / botsq)
24067        w1        = wqdip_peppho(1)
24068        w2        = wqdip_peppho(2)
24069 !       w1=0.0d0
24070 !       w2=0.0d0
24071 !       pis       = sig0head_scbase(itypi,itypj)
24072 !       eps_head   = epshead_scbase(itypi,itypj)
24073 !c!-------------------------------------------------------------------
24074
24075 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24076 !c!     &        +dhead(1,1,itypi,itypj))**2))
24077 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24078 !c!     &        +dhead(2,1,itypi,itypj))**2))
24079
24080 !c!-------------------------------------------------------------------
24081 !c! ecl
24082        sparrow  = w1  *  om1
24083        hawk     = w2 *  (1.0d0 - sqom1)
24084        Ecl = sparrow * rij_shift**2.0d0 &
24085            - hawk    * rij_shift**4.0d0
24086 !c!-------------------------------------------------------------------
24087 !c! derivative of ecl is Gcl
24088 !c! dF/dr part
24089 !       rij_shift=5.0
24090        dGCLdR  = - 2.0d0 * sparrow * rij_shift**3.0d0 &
24091                 + 4.0d0 * hawk    * rij_shift**5.0d0
24092 !c! dF/dom1
24093        dGCLdOM1 = (w1) * (rij_shift**2.0d0)
24094 !c! dF/dom2
24095        dGCLdOM2 = (2.0d0 * w2 * om1) * (rij_shift ** 4.0d0)
24096        eom1  =    dGCLdOM1+dGCLdOM2
24097        eom2  =    0.0
24098
24099           fac    = -expon * (c1 + evdwij) * rij_shift+dFdR+dGCLdR
24100 !          fac=0.0
24101           gg(1) =  fac*xj*rij
24102           gg(2) =  fac*yj*rij
24103           gg(3) =  fac*zj*rij
24104          do k=1,3
24105          gvdwc_peppho(k,j) = gvdwc_peppho(k,j) +gg(k)/2.0
24106          gvdwc_peppho(k,j+1) = gvdwc_peppho(k,j+1) +gg(k)/2.0
24107          gvdwc_peppho(k,i) = gvdwc_peppho(k,i) -gg(k)/2.0
24108          gvdwc_peppho(k,i+1) = gvdwc_peppho(k,i+1) -gg(k)/2.0
24109          gg(k)=0.0
24110          enddo
24111
24112       DO k = 1, 3
24113         dcosom1(k) = rij* (dc_norm(k,i) - om1 * erij(k))
24114         dcosom2(k) = rij* (dc_norm(k,j) - om2 * erij(k))
24115         gg(k) = gg(k) + eom1 * dcosom1(k)! + eom2 * dcosom2(k)
24116         gvdwc_peppho(k,j)= gvdwc_peppho(k,j)        +0.5*( gg(k))   !&
24117 !                 - (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24118         gvdwc_peppho(k,j+1)= gvdwc_peppho(k,j+1)    +0.5*( gg(k))   !&
24119 !                 + (eom2*(erij(k)-om2*dc_norm(k,j)))*dscj_inv*2.0
24120         gvdwc_peppho(k,i)= gvdwc_peppho(k,i)     -0.5*( gg(k))   &
24121                  - (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24122         gvdwc_peppho(k,i+1)= gvdwc_peppho(k,i+1) - 0.5*( gg(k))  &
24123                  + (eom1*(erij(k)-om1*dc_norm(k,i)))*dsci_inv*2.0
24124         enddo
24125        epeppho=epeppho+evdwij+Fcav+ECL
24126 !          print *,i,j,evdwij,Fcav,ECL,rij_shift
24127        enddo
24128        enddo
24129       end subroutine eprot_pep_phosphate
24130 !!!!!!!!!!!!!!!!-------------------------------------------------------------
24131       subroutine emomo(evdw)
24132       use calc_data
24133       use comm_momo
24134 !      implicit real*8 (a-h,o-z)
24135 !      include 'DIMENSIONS'
24136 !      include 'COMMON.GEO'
24137 !      include 'COMMON.VAR'
24138 !      include 'COMMON.LOCAL'
24139 !      include 'COMMON.CHAIN'
24140 !      include 'COMMON.DERIV'
24141 !      include 'COMMON.NAMES'
24142 !      include 'COMMON.INTERACT'
24143 !      include 'COMMON.IOUNITS'
24144 !      include 'COMMON.CALC'
24145 !      include 'COMMON.CONTROL'
24146 !      include 'COMMON.SBRIDGE'
24147       logical :: lprn
24148 !el local variables
24149       integer :: iint,itypi1,subchap,isel
24150       real(kind=8) :: rrij,xi,yi,zi,sig,rij_shift,e1,e2,sigm,epsi
24151       real(kind=8) :: evdw
24152       real(kind=8) :: xj_safe,yj_safe,zj_safe,xj_temp,yj_temp,zj_temp,&
24153                     dist_temp, dist_init,ssgradlipi,ssgradlipj, &
24154                     sslipi,sslipj,faclip,alpha_sco
24155       integer :: ii
24156       real(kind=8) :: fracinbuf
24157        real (kind=8) :: escpho
24158        real (kind=8),dimension(4):: ener
24159        real(kind=8) :: b1,b2,egb
24160        real(kind=8) :: Fisocav,ECL,Elj,Equad,Epol,eheadtail,&
24161         Lambf,&
24162         Chif,ChiLambf,Fcav,dFdR,dFdOM1,&
24163         dFdOM2,dFdL,dFdOM12,&
24164         federmaus,&
24165         d1i,d1j
24166 !       real(kind=8),dimension(3,2)::erhead_tail
24167 !       real(kind=8),dimension(3) :: Rhead_distance,ertail,erhead,Rtail_distance
24168        real(kind=8) ::  facd4, adler, Fgb, facd3
24169        integer troll,jj,istate
24170        real (kind=8) :: dcosom1(3),dcosom2(3)
24171        eps_out=80.0d0
24172        sss_ele_cut=1.0d0
24173 !       print *,"EVDW KURW",evdw,nres
24174       do i=iatsc_s,iatsc_e
24175 !        print *,"I am in EVDW",i
24176         itypi=iabs(itype(i,1))
24177 !        if (i.ne.47) cycle
24178         if (itypi.eq.ntyp1) cycle
24179         itypi1=iabs(itype(i+1,1))
24180         xi=c(1,nres+i)
24181         yi=c(2,nres+i)
24182         zi=c(3,nres+i)
24183           xi=dmod(xi,boxxsize)
24184           if (xi.lt.0) xi=xi+boxxsize
24185           yi=dmod(yi,boxysize)
24186           if (yi.lt.0) yi=yi+boxysize
24187           zi=dmod(zi,boxzsize)
24188           if (zi.lt.0) zi=zi+boxzsize
24189
24190        if ((zi.gt.bordlipbot)  &
24191         .and.(zi.lt.bordliptop)) then
24192 !C the energy transfer exist
24193         if (zi.lt.buflipbot) then
24194 !C what fraction I am in
24195          fracinbuf=1.0d0-  &
24196               ((zi-bordlipbot)/lipbufthick)
24197 !C lipbufthick is thickenes of lipid buffore
24198          sslipi=sscalelip(fracinbuf)
24199          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
24200         elseif (zi.gt.bufliptop) then
24201          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
24202          sslipi=sscalelip(fracinbuf)
24203          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
24204         else
24205          sslipi=1.0d0
24206          ssgradlipi=0.0
24207         endif
24208        else
24209          sslipi=0.0d0
24210          ssgradlipi=0.0
24211        endif
24212 !       print *, sslipi,ssgradlipi
24213         dxi=dc_norm(1,nres+i)
24214         dyi=dc_norm(2,nres+i)
24215         dzi=dc_norm(3,nres+i)
24216 !        dsci_inv=dsc_inv(itypi)
24217         dsci_inv=vbld_inv(i+nres)
24218 !       write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
24219 !       write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
24220 !
24221 ! Calculate SC interaction energy.
24222 !
24223         do iint=1,nint_gr(i)
24224           do j=istart(i,iint),iend(i,iint)
24225 !             print *,"JA PIER",i,j,iint,istart(i,iint),iend(i,iint)
24226             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
24227               call dyn_ssbond_ene(i,j,evdwij)
24228               evdw=evdw+evdwij
24229               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
24230                               'evdw',i,j,evdwij,' ss'
24231 !              if (energy_dec) write (iout,*) &
24232 !                              'evdw',i,j,evdwij,' ss'
24233              do k=j+1,iend(i,iint)
24234 !C search over all next residues
24235               if (dyn_ss_mask(k)) then
24236 !C check if they are cysteins
24237 !C              write(iout,*) 'k=',k
24238
24239 !c              write(iout,*) "PRZED TRI", evdwij
24240 !               evdwij_przed_tri=evdwij
24241               call triple_ssbond_ene(i,j,k,evdwij)
24242 !c               if(evdwij_przed_tri.ne.evdwij) then
24243 !c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
24244 !c               endif
24245
24246 !c              write(iout,*) "PO TRI", evdwij
24247 !C call the energy function that removes the artifical triple disulfide
24248 !C bond the soubroutine is located in ssMD.F
24249               evdw=evdw+evdwij
24250               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)') &
24251                             'evdw',i,j,evdwij,'tss'
24252               endif!dyn_ss_mask(k)
24253              enddo! k
24254             ELSE
24255 !el            ind=ind+1
24256             itypj=iabs(itype(j,1))
24257             if (itypj.eq.ntyp1) cycle
24258              CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
24259
24260 !             if (j.ne.78) cycle
24261 !            dscj_inv=dsc_inv(itypj)
24262             dscj_inv=vbld_inv(j+nres)
24263            xj=c(1,j+nres)
24264            yj=c(2,j+nres)
24265            zj=c(3,j+nres)
24266            xj=dmod(xj,boxxsize)
24267            if (xj.lt.0) xj=xj+boxxsize
24268            yj=dmod(yj,boxysize)
24269            if (yj.lt.0) yj=yj+boxysize
24270            zj=dmod(zj,boxzsize)
24271            if (zj.lt.0) zj=zj+boxzsize
24272           dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24273           xj_safe=xj
24274           yj_safe=yj
24275           zj_safe=zj
24276           subchap=0
24277
24278           do xshift=-1,1
24279           do yshift=-1,1
24280           do zshift=-1,1
24281           xj=xj_safe+xshift*boxxsize
24282           yj=yj_safe+yshift*boxysize
24283           zj=zj_safe+zshift*boxzsize
24284           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
24285           if(dist_temp.lt.dist_init) then
24286             dist_init=dist_temp
24287             xj_temp=xj
24288             yj_temp=yj
24289             zj_temp=zj
24290             subchap=1
24291           endif
24292           enddo
24293           enddo
24294           enddo
24295           if (subchap.eq.1) then
24296           xj=xj_temp-xi
24297           yj=yj_temp-yi
24298           zj=zj_temp-zi
24299           else
24300           xj=xj_safe-xi
24301           yj=yj_safe-yi
24302           zj=zj_safe-zi
24303           endif
24304           dxj = dc_norm( 1, nres+j )
24305           dyj = dc_norm( 2, nres+j )
24306           dzj = dc_norm( 3, nres+j )
24307 !          print *,i,j,itypi,itypj
24308 !          d1i=0.0d0
24309 !          d1j=0.0d0
24310 !          BetaT = 1.0d0 / (298.0d0 * Rb)
24311 ! Gay-berne var's
24312 !1!          sig0ij = sigma_scsc( itypi,itypj )
24313 !          chi1=0.0d0
24314 !          chi2=0.0d0
24315 !          chip1=0.0d0
24316 !          chip2=0.0d0
24317 ! not used by momo potential, but needed by sc_angular which is shared
24318 ! by all energy_potential subroutines
24319           alf1   = 0.0d0
24320           alf2   = 0.0d0
24321           alf12  = 0.0d0
24322           a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
24323 !       a12sq = a12sq * a12sq
24324 ! charge of amino acid itypi is...
24325           chis1 = chis(itypi,itypj)
24326           chis2 = chis(itypj,itypi)
24327           chis12 = chis1 * chis2
24328           sig1 = sigmap1(itypi,itypj)
24329           sig2 = sigmap2(itypi,itypj)
24330 !       write (*,*) "sig1 = ", sig1
24331 !          chis1=0.0
24332 !          chis2=0.0
24333 !                    chis12 = chis1 * chis2
24334 !          sig1=0.0
24335 !          sig2=0.0
24336 !       write (*,*) "sig2 = ", sig2
24337 ! alpha factors from Fcav/Gcav
24338           b1cav = alphasur(1,itypi,itypj)
24339 !          b1cav=0.0d0
24340           b2cav = alphasur(2,itypi,itypj)
24341           b3cav = alphasur(3,itypi,itypj)
24342           b4cav = alphasur(4,itypi,itypj)
24343 ! used to determine whether we want to do quadrupole calculations
24344        eps_in = epsintab(itypi,itypj)
24345        if (eps_in.eq.0.0) eps_in=1.0
24346
24347        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
24348        Rtail = 0.0d0
24349 !       dtail(1,itypi,itypj)=0.0
24350 !       dtail(2,itypi,itypj)=0.0
24351
24352        DO k = 1, 3
24353         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
24354         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
24355        END DO
24356 !c! tail distances will be themselves usefull elswhere
24357 !c1 (in Gcav, for example)
24358        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
24359        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
24360        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
24361        Rtail = dsqrt( &
24362           (Rtail_distance(1)*Rtail_distance(1)) &
24363         + (Rtail_distance(2)*Rtail_distance(2)) &
24364         + (Rtail_distance(3)*Rtail_distance(3)))
24365
24366 !       write (*,*) "eps_inout_fac = ", eps_inout_fac
24367 !-------------------------------------------------------------------
24368 ! tail location and distance calculations
24369        d1 = dhead(1, 1, itypi, itypj)
24370        d2 = dhead(2, 1, itypi, itypj)
24371
24372        DO k = 1,3
24373 ! location of polar head is computed by taking hydrophobic centre
24374 ! and moving by a d1 * dc_norm vector
24375 ! see unres publications for very informative images
24376         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
24377         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
24378 ! distance
24379 !        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
24380 !        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
24381         Rhead_distance(k) = chead(k,2) - chead(k,1)
24382        END DO
24383 ! pitagoras (root of sum of squares)
24384        Rhead = dsqrt( &
24385           (Rhead_distance(1)*Rhead_distance(1)) &
24386         + (Rhead_distance(2)*Rhead_distance(2)) &
24387         + (Rhead_distance(3)*Rhead_distance(3)))
24388 !-------------------------------------------------------------------
24389 ! zero everything that should be zero'ed
24390        evdwij = 0.0d0
24391        ECL = 0.0d0
24392        Elj = 0.0d0
24393        Equad = 0.0d0
24394        Epol = 0.0d0
24395        Fcav=0.0d0
24396        eheadtail = 0.0d0
24397        dGCLdOM1 = 0.0d0
24398        dGCLdOM2 = 0.0d0
24399        dGCLdOM12 = 0.0d0
24400        dPOLdOM1 = 0.0d0
24401        dPOLdOM2 = 0.0d0
24402           Fcav = 0.0d0
24403           dFdR = 0.0d0
24404           dCAVdOM1  = 0.0d0
24405           dCAVdOM2  = 0.0d0
24406           dCAVdOM12 = 0.0d0
24407           dscj_inv = vbld_inv(j+nres)
24408 !          print *,i,j,dscj_inv,dsci_inv
24409 ! rij holds 1/(distance of Calpha atoms)
24410           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
24411           rij  = dsqrt(rrij)
24412 !----------------------------
24413           CALL sc_angular
24414 ! this should be in elgrad_init but om's are calculated by sc_angular
24415 ! which in turn is used by older potentials
24416 ! om = omega, sqom = om^2
24417           sqom1  = om1 * om1
24418           sqom2  = om2 * om2
24419           sqom12 = om12 * om12
24420
24421 ! now we calculate EGB - Gey-Berne
24422 ! It will be summed up in evdwij and saved in evdw
24423           sigsq     = 1.0D0  / sigsq
24424           sig       = sig0ij * dsqrt(sigsq)
24425 !          rij_shift = 1.0D0  / rij - sig + sig0ij
24426           rij_shift = Rtail - sig + sig0ij
24427           IF (rij_shift.le.0.0D0) THEN
24428            evdw = 1.0D20
24429            RETURN
24430           END IF
24431           sigder = -sig * sigsq
24432           rij_shift = 1.0D0 / rij_shift
24433           fac       = rij_shift**expon
24434           c1        = fac  * fac * aa_aq(itypi,itypj)
24435 !          print *,"ADAM",aa_aq(itypi,itypj)
24436
24437 !          c1        = 0.0d0
24438           c2        = fac  * bb_aq(itypi,itypj)
24439 !          c2        = 0.0d0
24440           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
24441           eps2der   = eps3rt * evdwij
24442           eps3der   = eps2rt * evdwij
24443 !          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
24444           evdwij    = eps2rt * eps3rt * evdwij
24445 !#ifdef TSCSC
24446 !          IF (bb_aq(itypi,itypj).gt.0) THEN
24447 !           evdw_p = evdw_p + evdwij
24448 !          ELSE
24449 !           evdw_m = evdw_m + evdwij
24450 !          END IF
24451 !#else
24452           evdw = evdw  &
24453               + evdwij
24454 !#endif
24455
24456           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
24457           fac    = -expon * (c1 + evdwij) * rij_shift
24458           sigder = fac * sigder
24459 !          fac    = rij * fac
24460 ! Calculate distance derivative
24461           gg(1) =  fac
24462           gg(2) =  fac
24463           gg(3) =  fac
24464 !          if (b2.gt.0.0) then
24465           fac = chis1 * sqom1 + chis2 * sqom2 &
24466           - 2.0d0 * chis12 * om1 * om2 * om12
24467 ! we will use pom later in Gcav, so dont mess with it!
24468           pom = 1.0d0 - chis1 * chis2 * sqom12
24469           Lambf = (1.0d0 - (fac / pom))
24470 !          print *,"fac,pom",fac,pom,Lambf
24471           Lambf = dsqrt(Lambf)
24472           sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
24473 !          print *,"sig1,sig2",sig1,sig2,itypi,itypj
24474 !       write (*,*) "sparrow = ", sparrow
24475           Chif = Rtail * sparrow
24476 !           print *,"rij,sparrow",rij , sparrow
24477           ChiLambf = Chif * Lambf
24478           eagle = dsqrt(ChiLambf)
24479           bat = ChiLambf ** 11.0d0
24480           top = b1cav * ( eagle + b2cav * ChiLambf - b3cav )
24481           bot = 1.0d0 + b4cav * (ChiLambf ** 12.0d0)
24482           botsq = bot * bot
24483 !          print *,top,bot,"bot,top",ChiLambf,Chif
24484           Fcav = top / bot
24485
24486        dtop = b1cav * ((Lambf / (2.0d0 * eagle)) + (b2cav * Lambf))
24487        dbot = 12.0d0 * b4cav * bat * Lambf
24488        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
24489
24490           dtop = b1cav * ((Chif / (2.0d0 * eagle)) + (b2cav * Chif))
24491           dbot = 12.0d0 * b4cav * bat * Chif
24492           eagle = Lambf * pom
24493           dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
24494           dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
24495           dFdOM12 = chis12 * (chis1 * om1 * om12 - om2) &
24496               * (chis2 * om2 * om12 - om1) / (eagle * pom)
24497
24498           dFdL = ((dtop * bot - top * dbot) / botsq)
24499 !       dFdL = 0.0d0
24500           dCAVdOM1  = dFdL * ( dFdOM1 )
24501           dCAVdOM2  = dFdL * ( dFdOM2 )
24502           dCAVdOM12 = dFdL * ( dFdOM12 )
24503
24504        DO k= 1, 3
24505         ertail(k) = Rtail_distance(k)/Rtail
24506        END DO
24507        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
24508        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
24509        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
24510        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24511        DO k = 1, 3
24512 !c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24513 !c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24514         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
24515         gvdwx(k,i) = gvdwx(k,i) &
24516                   - (( dFdR + gg(k) ) * pom)
24517 !c!     &             - ( dFdR * pom )
24518         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
24519         gvdwx(k,j) = gvdwx(k,j)   &
24520                   + (( dFdR + gg(k) ) * pom)
24521 !c!     &             + ( dFdR * pom )
24522
24523         gvdwc(k,i) = gvdwc(k,i)  &
24524                   - (( dFdR + gg(k) ) * ertail(k))
24525 !c!     &             - ( dFdR * ertail(k))
24526
24527         gvdwc(k,j) = gvdwc(k,j) &
24528                   + (( dFdR + gg(k) ) * ertail(k))
24529 !c!     &             + ( dFdR * ertail(k))
24530
24531         gg(k) = 0.0d0
24532 !      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
24533 !      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
24534       END DO
24535
24536
24537 !c! Compute head-head and head-tail energies for each state
24538
24539           isel = iabs(Qi) + iabs(Qj)
24540 !          isel=0
24541           IF (isel.eq.0) THEN
24542 !c! No charges - do nothing
24543            eheadtail = 0.0d0
24544
24545           ELSE IF (isel.eq.4) THEN
24546 !c! Calculate dipole-dipole interactions
24547            CALL edd(ecl)
24548            eheadtail = ECL
24549 !           eheadtail = 0.0d0
24550
24551           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
24552 !c! Charge-nonpolar interactions
24553            CALL eqn(epol)
24554            eheadtail = epol
24555 !           eheadtail = 0.0d0
24556
24557           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
24558 !c! Nonpolar-charge interactions
24559            CALL enq(epol)
24560            eheadtail = epol
24561 !           eheadtail = 0.0d0
24562
24563           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
24564 !c! Charge-dipole interactions
24565            CALL eqd(ecl, elj, epol)
24566            eheadtail = ECL + elj + epol
24567 !           eheadtail = 0.0d0
24568
24569           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
24570 !c! Dipole-charge interactions
24571            CALL edq(ecl, elj, epol)
24572           eheadtail = ECL + elj + epol
24573 !           eheadtail = 0.0d0
24574
24575           ELSE IF ((isel.eq.2.and.   &
24576                iabs(Qi).eq.1).and.  &
24577                nstate(itypi,itypj).eq.1) THEN
24578 !c! Same charge-charge interaction ( +/+ or -/- )
24579            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
24580            eheadtail = ECL + Egb + Epol + Fisocav + Elj
24581 !           eheadtail = 0.0d0
24582
24583           ELSE IF ((isel.eq.2.and.  &
24584                iabs(Qi).eq.1).and. &
24585                nstate(itypi,itypj).ne.1) THEN
24586 !c! Different charge-charge interaction ( +/- or -/+ )
24587            CALL energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
24588           END IF
24589        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
24590       evdw = evdw  + Fcav + eheadtail
24591
24592        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,10f16.7)') &
24593         restyp(itype(i,1),1),i,restyp(itype(j,1),1),j,&
24594         1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,&
24595         Equad,evdwij+Fcav+eheadtail,evdw
24596 !       evdw = evdw  + Fcav  + eheadtail
24597
24598         iF (nstate(itypi,itypj).eq.1) THEN
24599         CALL sc_grad
24600        END IF
24601 !c!-------------------------------------------------------------------
24602 !c! NAPISY KONCOWE
24603          END DO   ! j
24604         END DO    ! iint
24605        END DO     ! i
24606 !c      write (iout,*) "Number of loop steps in EGB:",ind
24607 !c      energy_dec=.false.
24608 !              print *,"EVDW KURW",evdw,nres
24609
24610        RETURN
24611       END SUBROUTINE emomo
24612 !C------------------------------------------------------------------------------------
24613       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
24614       use calc_data
24615       use comm_momo
24616        real (kind=8) ::  facd3, facd4, federmaus, adler,&
24617          Ecl,Egb,Epol,Fisocav,Elj,Fgb
24618 !       integer :: k
24619 !c! Epol and Gpol analytical parameters
24620        alphapol1 = alphapol(itypi,itypj)
24621        alphapol2 = alphapol(itypj,itypi)
24622 !c! Fisocav and Gisocav analytical parameters
24623        al1  = alphiso(1,itypi,itypj)
24624        al2  = alphiso(2,itypi,itypj)
24625        al3  = alphiso(3,itypi,itypj)
24626        al4  = alphiso(4,itypi,itypj)
24627        csig = (1.0d0  &
24628            / dsqrt(sigiso1(itypi, itypj)**2.0d0 &
24629            + sigiso2(itypi,itypj)**2.0d0))
24630 !c!
24631        pis  = sig0head(itypi,itypj)
24632        eps_head = epshead(itypi,itypj)
24633        Rhead_sq = Rhead * Rhead
24634 !c! R1 - distance between head of ith side chain and tail of jth sidechain
24635 !c! R2 - distance between head of jth side chain and tail of ith sidechain
24636        R1 = 0.0d0
24637        R2 = 0.0d0
24638        DO k = 1, 3
24639 !c! Calculate head-to-tail distances needed by Epol
24640         R1=R1+(ctail(k,2)-chead(k,1))**2
24641         R2=R2+(chead(k,2)-ctail(k,1))**2
24642        END DO
24643 !c! Pitagoras
24644        R1 = dsqrt(R1)
24645        R2 = dsqrt(R2)
24646
24647 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
24648 !c!     &        +dhead(1,1,itypi,itypj))**2))
24649 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
24650 !c!     &        +dhead(2,1,itypi,itypj))**2))
24651
24652 !c!-------------------------------------------------------------------
24653 !c! Coulomb electrostatic interaction
24654        Ecl = (332.0d0 * Qij) / Rhead
24655 !c! derivative of Ecl is Gcl...
24656        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
24657        dGCLdOM1 = 0.0d0
24658        dGCLdOM2 = 0.0d0
24659        dGCLdOM12 = 0.0d0
24660        ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
24661        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
24662        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
24663 !       print *,"EGB WTF",Qij,eps_inout_fac,Fgb,itypi,itypj,eps_in,eps_out
24664 !c! Derivative of Egb is Ggb...
24665        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
24666        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )/ ( 2.0d0 * Fgb )
24667        dGGBdR = dGGBdFGB * dFGBdR
24668 !c!-------------------------------------------------------------------
24669 !c! Fisocav - isotropic cavity creation term
24670 !c! or "how much energy it costs to put charged head in water"
24671        pom = Rhead * csig
24672        top = al1 * (dsqrt(pom) + al2 * pom - al3)
24673        bot = (1.0d0 + al4 * pom**12.0d0)
24674        botsq = bot * bot
24675        FisoCav = top / bot
24676 !      write (*,*) "Rhead = ",Rhead
24677 !      write (*,*) "csig = ",csig
24678 !      write (*,*) "pom = ",pom
24679 !      write (*,*) "al1 = ",al1
24680 !      write (*,*) "al2 = ",al2
24681 !      write (*,*) "al3 = ",al3
24682 !      write (*,*) "al4 = ",al4
24683 !        write (*,*) "top = ",top
24684 !        write (*,*) "bot = ",bot
24685 !c! Derivative of Fisocav is GCV...
24686        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
24687        dbot = 12.0d0 * al4 * pom ** 11.0d0
24688        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
24689 !c!-------------------------------------------------------------------
24690 !c! Epol
24691 !c! Polarization energy - charged heads polarize hydrophobic "neck"
24692        MomoFac1 = (1.0d0 - chi1 * sqom2)
24693        MomoFac2 = (1.0d0 - chi2 * sqom1)
24694        RR1  = ( R1 * R1 ) / MomoFac1
24695        RR2  = ( R2 * R2 ) / MomoFac2
24696        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24697        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
24698        fgb1 = sqrt( RR1 + a12sq * ee1 )
24699        fgb2 = sqrt( RR2 + a12sq * ee2 )
24700        epol = 332.0d0 * eps_inout_fac * ( &
24701       (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
24702 !c!       epol = 0.0d0
24703        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
24704                / (fgb1 ** 5.0d0)
24705        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
24706                / (fgb2 ** 5.0d0)
24707        dFGBdR1 = ( (R1 / MomoFac1)* ( 2.0d0 - (0.5d0 * ee1) ) )&
24708              / ( 2.0d0 * fgb1 )
24709        dFGBdR2 = ( (R2 / MomoFac2)* ( 2.0d0 - (0.5d0 * ee2) ) )&
24710              / ( 2.0d0 * fgb2 )
24711        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))&
24712                 * ( 2.0d0 - 0.5d0 * ee1) ) / ( 2.0d0 * fgb1 )
24713        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))&
24714                 * ( 2.0d0 - 0.5d0 * ee2) ) / ( 2.0d0 * fgb2 )
24715        dPOLdR1 = dPOLdFGB1 * dFGBdR1
24716 !c!       dPOLdR1 = 0.0d0
24717        dPOLdR2 = dPOLdFGB2 * dFGBdR2
24718 !c!       dPOLdR2 = 0.0d0
24719        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
24720 !c!       dPOLdOM1 = 0.0d0
24721        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
24722 !c!       dPOLdOM2 = 0.0d0
24723 !c!-------------------------------------------------------------------
24724 !c! Elj
24725 !c! Lennard-Jones 6-12 interaction between heads
24726        pom = (pis / Rhead)**6.0d0
24727        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
24728 !c! derivative of Elj is Glj
24729        dGLJdR = 4.0d0 * eps_head*(((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))&
24730              +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
24731 !c!-------------------------------------------------------------------
24732 !c! Return the results
24733 !c! These things do the dRdX derivatives, that is
24734 !c! allow us to change what we see from function that changes with
24735 !c! distance to function that changes with LOCATION (of the interaction
24736 !c! site)
24737        DO k = 1, 3
24738         erhead(k) = Rhead_distance(k)/Rhead
24739         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
24740         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
24741        END DO
24742
24743        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
24744        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
24745        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
24746        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
24747        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
24748        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
24749        facd1 = d1 * vbld_inv(i+nres)
24750        facd2 = d2 * vbld_inv(j+nres)
24751        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
24752        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
24753
24754 !c! Now we add appropriate partial derivatives (one in each dimension)
24755        DO k = 1, 3
24756         hawk   = (erhead_tail(k,1) + &
24757         facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
24758         condor = (erhead_tail(k,2) + &
24759         facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
24760
24761         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
24762         gvdwx(k,i) = gvdwx(k,i) &
24763                   - dGCLdR * pom&
24764                   - dGGBdR * pom&
24765                   - dGCVdR * pom&
24766                   - dPOLdR1 * hawk&
24767                   - dPOLdR2 * (erhead_tail(k,2)&
24768       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
24769                   - dGLJdR * pom
24770
24771         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
24772         gvdwx(k,j) = gvdwx(k,j)+ dGCLdR * pom&
24773                    + dGGBdR * pom+ dGCVdR * pom&
24774                   + dPOLdR1 * (erhead_tail(k,1)&
24775       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))&
24776                   + dPOLdR2 * condor + dGLJdR * pom
24777
24778         gvdwc(k,i) = gvdwc(k,i)  &
24779                   - dGCLdR * erhead(k)&
24780                   - dGGBdR * erhead(k)&
24781                   - dGCVdR * erhead(k)&
24782                   - dPOLdR1 * erhead_tail(k,1)&
24783                   - dPOLdR2 * erhead_tail(k,2)&
24784                   - dGLJdR * erhead(k)
24785
24786         gvdwc(k,j) = gvdwc(k,j)         &
24787                   + dGCLdR * erhead(k) &
24788                   + dGGBdR * erhead(k) &
24789                   + dGCVdR * erhead(k) &
24790                   + dPOLdR1 * erhead_tail(k,1) &
24791                   + dPOLdR2 * erhead_tail(k,2)&
24792                   + dGLJdR * erhead(k)
24793
24794        END DO
24795        RETURN
24796       END SUBROUTINE eqq
24797 !c!-------------------------------------------------------------------
24798       SUBROUTINE energy_quad(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
24799       use comm_momo
24800       use calc_data
24801
24802        double precision eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad
24803        double precision ener(4)
24804        double precision dcosom1(3),dcosom2(3)
24805 !c! used in Epol derivatives
24806        double precision facd3, facd4
24807        double precision federmaus, adler
24808        integer istate,ii,jj
24809        real (kind=8) :: Fgb
24810 !       print *,"CALLING EQUAD"
24811 !c! Epol and Gpol analytical parameters
24812        alphapol1 = alphapol(itypi,itypj)
24813        alphapol2 = alphapol(itypj,itypi)
24814 !c! Fisocav and Gisocav analytical parameters
24815        al1  = alphiso(1,itypi,itypj)
24816        al2  = alphiso(2,itypi,itypj)
24817        al3  = alphiso(3,itypi,itypj)
24818        al4  = alphiso(4,itypi,itypj)
24819        csig = (1.0d0 / dsqrt(sigiso1(itypi, itypj)**2.0d0&
24820             + sigiso2(itypi,itypj)**2.0d0))
24821 !c!
24822        w1   = wqdip(1,itypi,itypj)
24823        w2   = wqdip(2,itypi,itypj)
24824        pis  = sig0head(itypi,itypj)
24825        eps_head = epshead(itypi,itypj)
24826 !c! First things first:
24827 !c! We need to do sc_grad's job with GB and Fcav
24828        eom1  = eps2der * eps2rt_om1 &
24829              - 2.0D0 * alf1 * eps3der&
24830              + sigder * sigsq_om1&
24831              + dCAVdOM1
24832        eom2  = eps2der * eps2rt_om2 &
24833              + 2.0D0 * alf2 * eps3der&
24834              + sigder * sigsq_om2&
24835              + dCAVdOM2
24836        eom12 =  evdwij  * eps1_om12 &
24837              + eps2der * eps2rt_om12 &
24838              - 2.0D0 * alf12 * eps3der&
24839              + sigder *sigsq_om12&
24840              + dCAVdOM12
24841 !c! now some magical transformations to project gradient into
24842 !c! three cartesian vectors
24843        DO k = 1, 3
24844         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
24845         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
24846         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
24847 !c! this acts on hydrophobic center of interaction
24848         gvdwx(k,i)= gvdwx(k,i) - gg(k) &
24849                   + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
24850                   + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
24851         gvdwx(k,j)= gvdwx(k,j) + gg(k) &
24852                   + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))&
24853                   + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
24854 !c! this acts on Calpha
24855         gvdwc(k,i)=gvdwc(k,i)-gg(k)
24856         gvdwc(k,j)=gvdwc(k,j)+gg(k)
24857        END DO
24858 !c! sc_grad is done, now we will compute
24859        eheadtail = 0.0d0
24860        eom1 = 0.0d0
24861        eom2 = 0.0d0
24862        eom12 = 0.0d0
24863        DO istate = 1, nstate(itypi,itypj)
24864 !c*************************************************************
24865         IF (istate.ne.1) THEN
24866          IF (istate.lt.3) THEN
24867           ii = 1
24868          ELSE
24869           ii = 2
24870          END IF
24871         jj = istate/ii
24872         d1 = dhead(1,ii,itypi,itypj)
24873         d2 = dhead(2,jj,itypi,itypj)
24874         DO k = 1,3
24875          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
24876          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
24877          Rhead_distance(k) = chead(k,2) - chead(k,1)
24878         END DO
24879 !c! pitagoras (root of sum of squares)
24880         Rhead = dsqrt( &
24881                (Rhead_distance(1)*Rhead_distance(1))  &
24882              + (Rhead_distance(2)*Rhead_distance(2))  &
24883              + (Rhead_distance(3)*Rhead_distance(3)))
24884         END IF
24885         Rhead_sq = Rhead * Rhead
24886
24887 !c! R1 - distance between head of ith side chain and tail of jth sidechain
24888 !c! R2 - distance between head of jth side chain and tail of ith sidechain
24889         R1 = 0.0d0
24890         R2 = 0.0d0
24891         DO k = 1, 3
24892 !c! Calculate head-to-tail distances
24893          R1=R1+(ctail(k,2)-chead(k,1))**2
24894          R2=R2+(chead(k,2)-ctail(k,1))**2
24895         END DO
24896 !c! Pitagoras
24897         R1 = dsqrt(R1)
24898         R2 = dsqrt(R2)
24899         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
24900 !c!        Ecl = 0.0d0
24901 !c!        write (*,*) "Ecl = ", Ecl
24902 !c! derivative of Ecl is Gcl...
24903         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
24904 !c!        dGCLdR = 0.0d0
24905         dGCLdOM1 = 0.0d0
24906         dGCLdOM2 = 0.0d0
24907         dGCLdOM12 = 0.0d0
24908 !c!-------------------------------------------------------------------
24909 !c! Generalised Born Solvent Polarization
24910         ee0 = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
24911         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee0)
24912         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
24913 !c!        Egb = 0.0d0
24914 !c!      write (*,*) "a1*a2 = ", a12sq
24915 !c!      write (*,*) "Rhead = ", Rhead
24916 !c!      write (*,*) "Rhead_sq = ", Rhead_sq
24917 !c!      write (*,*) "ee = ", ee
24918 !c!      write (*,*) "Fgb = ", Fgb
24919 !c!      write (*,*) "fac = ", eps_inout_fac
24920 !c!      write (*,*) "Qij = ", Qij
24921 !c!      write (*,*) "Egb = ", Egb
24922 !c! Derivative of Egb is Ggb...
24923 !c! dFGBdR is used by Quad's later...
24924         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
24925         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee0) ) )&
24926                / ( 2.0d0 * Fgb )
24927         dGGBdR = dGGBdFGB * dFGBdR
24928 !c!        dGGBdR = 0.0d0
24929 !c!-------------------------------------------------------------------
24930 !c! Fisocav - isotropic cavity creation term
24931         pom = Rhead * csig
24932         top = al1 * (dsqrt(pom) + al2 * pom - al3)
24933         bot = (1.0d0 + al4 * pom**12.0d0)
24934         botsq = bot * bot
24935         FisoCav = top / bot
24936         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
24937         dbot = 12.0d0 * al4 * pom ** 11.0d0
24938         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
24939 !c!        dGCVdR = 0.0d0
24940 !c!-------------------------------------------------------------------
24941 !c! Polarization energy
24942 !c! Epol
24943         MomoFac1 = (1.0d0 - chi1 * sqom2)
24944         MomoFac2 = (1.0d0 - chi2 * sqom1)
24945         RR1  = ( R1 * R1 ) / MomoFac1
24946         RR2  = ( R2 * R2 ) / MomoFac2
24947         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
24948         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
24949         fgb1 = sqrt( RR1 + a12sq * ee1 )
24950         fgb2 = sqrt( RR2 + a12sq * ee2 )
24951         epol = 332.0d0 * eps_inout_fac * (&
24952         (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
24953 !c!        epol = 0.0d0
24954 !c! derivative of Epol is Gpol...
24955         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)&
24956                   / (fgb1 ** 5.0d0)
24957         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)&
24958                   / (fgb2 ** 5.0d0)
24959         dFGBdR1 = ( (R1 / MomoFac1) &
24960                 * ( 2.0d0 - (0.5d0 * ee1) ) )&
24961                 / ( 2.0d0 * fgb1 )
24962         dFGBdR2 = ( (R2 / MomoFac2) &
24963                 * ( 2.0d0 - (0.5d0 * ee2) ) ) &
24964                 / ( 2.0d0 * fgb2 )
24965         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
24966                  * ( 2.0d0 - 0.5d0 * ee1) ) &
24967                  / ( 2.0d0 * fgb1 )
24968         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
24969                  * ( 2.0d0 - 0.5d0 * ee2) ) &
24970                  / ( 2.0d0 * fgb2 )
24971         dPOLdR1 = dPOLdFGB1 * dFGBdR1
24972 !c!        dPOLdR1 = 0.0d0
24973         dPOLdR2 = dPOLdFGB2 * dFGBdR2
24974 !c!        dPOLdR2 = 0.0d0
24975         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
24976 !c!        dPOLdOM1 = 0.0d0
24977         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
24978         pom = (pis / Rhead)**6.0d0
24979         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
24980 !c!        Elj = 0.0d0
24981 !c! derivative of Elj is Glj
24982         dGLJdR = 4.0d0 * eps_head &
24983             * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
24984             +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
24985 !c!        dGLJdR = 0.0d0
24986 !c!-------------------------------------------------------------------
24987 !c! Equad
24988        IF (Wqd.ne.0.0d0) THEN
24989         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0) &
24990              - 37.5d0  * ( sqom1 + sqom2 ) &
24991              + 157.5d0 * ( sqom1 * sqom2 ) &
24992              - 45.0d0  * om1*om2*om12
24993         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
24994         Equad = fac * Beta1
24995 !c!        Equad = 0.0d0
24996 !c! derivative of Equad...
24997         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
24998 !c!        dQUADdR = 0.0d0
24999         dQUADdOM1 = fac* (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
25000 !c!        dQUADdOM1 = 0.0d0
25001         dQUADdOM2 = fac* (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
25002 !c!        dQUADdOM2 = 0.0d0
25003         dQUADdOM12 = fac * ( 6.0d0*om12 - 45.0d0*om1*om2 )
25004        ELSE
25005          Beta1 = 0.0d0
25006          Equad = 0.0d0
25007         END IF
25008 !c!-------------------------------------------------------------------
25009 !c! Return the results
25010 !c! Angular stuff
25011         eom1 = dPOLdOM1 + dQUADdOM1
25012         eom2 = dPOLdOM2 + dQUADdOM2
25013         eom12 = dQUADdOM12
25014 !c! now some magical transformations to project gradient into
25015 !c! three cartesian vectors
25016         DO k = 1, 3
25017          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
25018          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
25019          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
25020         END DO
25021 !c! Radial stuff
25022         DO k = 1, 3
25023          erhead(k) = Rhead_distance(k)/Rhead
25024          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25025          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25026         END DO
25027         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25028         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25029         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25030         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25031         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25032         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25033         facd1 = d1 * vbld_inv(i+nres)
25034         facd2 = d2 * vbld_inv(j+nres)
25035         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25036         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25037         DO k = 1, 3
25038          hawk   = erhead_tail(k,1) + &
25039          facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
25040          condor = erhead_tail(k,2) + &
25041          facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
25042
25043          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25044 !c! this acts on hydrophobic center of interaction
25045          gheadtail(k,1,1) = gheadtail(k,1,1) &
25046                          - dGCLdR * pom &
25047                          - dGGBdR * pom &
25048                          - dGCVdR * pom &
25049                          - dPOLdR1 * hawk &
25050                          - dPOLdR2 * (erhead_tail(k,2) &
25051       -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))&
25052                          - dGLJdR * pom &
25053                          - dQUADdR * pom&
25054                          - tuna(k) &
25055                  + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))&
25056                  + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
25057
25058          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25059 !c! this acts on hydrophobic center of interaction
25060          gheadtail(k,2,1) = gheadtail(k,2,1)  &
25061                          + dGCLdR * pom      &
25062                          + dGGBdR * pom      &
25063                          + dGCVdR * pom      &
25064                          + dPOLdR1 * (erhead_tail(k,1) &
25065       -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
25066                          + dPOLdR2 * condor &
25067                          + dGLJdR * pom &
25068                          + dQUADdR * pom &
25069                          + tuna(k) &
25070                  + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j)) &
25071                  + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
25072
25073 !c! this acts on Calpha
25074          gheadtail(k,3,1) = gheadtail(k,3,1)  &
25075                          - dGCLdR * erhead(k)&
25076                          - dGGBdR * erhead(k)&
25077                          - dGCVdR * erhead(k)&
25078                          - dPOLdR1 * erhead_tail(k,1)&
25079                          - dPOLdR2 * erhead_tail(k,2)&
25080                          - dGLJdR * erhead(k) &
25081                          - dQUADdR * erhead(k)&
25082                          - tuna(k)
25083 !c! this acts on Calpha
25084          gheadtail(k,4,1) = gheadtail(k,4,1)   &
25085                           + dGCLdR * erhead(k) &
25086                           + dGGBdR * erhead(k) &
25087                           + dGCVdR * erhead(k) &
25088                           + dPOLdR1 * erhead_tail(k,1) &
25089                           + dPOLdR2 * erhead_tail(k,2) &
25090                           + dGLJdR * erhead(k) &
25091                           + dQUADdR * erhead(k)&
25092                           + tuna(k)
25093         END DO
25094         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
25095         eheadtail = eheadtail &
25096                   + wstate(istate, itypi, itypj) &
25097                   * dexp(-betaT * ener(istate))
25098 !c! foreach cartesian dimension
25099         DO k = 1, 3
25100 !c! foreach of two gvdwx and gvdwc
25101          DO l = 1, 4
25102           gheadtail(k,l,2) = gheadtail(k,l,2)  &
25103                            + wstate( istate, itypi, itypj ) &
25104                            * dexp(-betaT * ener(istate)) &
25105                            * gheadtail(k,l,1)
25106           gheadtail(k,l,1) = 0.0d0
25107          END DO
25108         END DO
25109        END DO
25110 !c! Here ended the gigantic DO istate = 1, 4, which starts
25111 !c! at the beggining of the subroutine
25112
25113        DO k = 1, 3
25114         DO l = 1, 4
25115          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
25116         END DO
25117         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
25118         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
25119         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
25120         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
25121         DO l = 1, 4
25122          gheadtail(k,l,1) = 0.0d0
25123          gheadtail(k,l,2) = 0.0d0
25124         END DO
25125        END DO
25126        eheadtail = (-dlog(eheadtail)) / betaT
25127        dPOLdOM1 = 0.0d0
25128        dPOLdOM2 = 0.0d0
25129        dQUADdOM1 = 0.0d0
25130        dQUADdOM2 = 0.0d0
25131        dQUADdOM12 = 0.0d0
25132        RETURN
25133       END SUBROUTINE energy_quad
25134 !!-----------------------------------------------------------
25135       SUBROUTINE eqn(Epol)
25136       use comm_momo
25137       use calc_data
25138
25139       double precision  facd4, federmaus,epol
25140       alphapol1 = alphapol(itypi,itypj)
25141 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25142        R1 = 0.0d0
25143        DO k = 1, 3
25144 !c! Calculate head-to-tail distances
25145         R1=R1+(ctail(k,2)-chead(k,1))**2
25146        END DO
25147 !c! Pitagoras
25148        R1 = dsqrt(R1)
25149
25150 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25151 !c!     &        +dhead(1,1,itypi,itypj))**2))
25152 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25153 !c!     &        +dhead(2,1,itypi,itypj))**2))
25154 !c--------------------------------------------------------------------
25155 !c Polarization energy
25156 !c Epol
25157        MomoFac1 = (1.0d0 - chi1 * sqom2)
25158        RR1  = R1 * R1 / MomoFac1
25159        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25160        fgb1 = sqrt( RR1 + a12sq * ee1)
25161        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
25162        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
25163                / (fgb1 ** 5.0d0)
25164        dFGBdR1 = ( (R1 / MomoFac1) &
25165               * ( 2.0d0 - (0.5d0 * ee1) ) ) &
25166               / ( 2.0d0 * fgb1 )
25167        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25168                 * (2.0d0 - 0.5d0 * ee1) ) &
25169                 / (2.0d0 * fgb1)
25170        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25171 !c!       dPOLdR1 = 0.0d0
25172        dPOLdOM1 = 0.0d0
25173        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25174        DO k = 1, 3
25175         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25176        END DO
25177        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25178        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25179        facd1 = d1 * vbld_inv(i+nres)
25180        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25181
25182        DO k = 1, 3
25183         hawk = (erhead_tail(k,1) + &
25184         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
25185
25186         gvdwx(k,i) = gvdwx(k,i) &
25187                    - dPOLdR1 * hawk
25188         gvdwx(k,j) = gvdwx(k,j) &
25189                    + dPOLdR1 * (erhead_tail(k,1) &
25190        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
25191
25192         gvdwc(k,i) = gvdwc(k,i)  - dPOLdR1 * erhead_tail(k,1)
25193         gvdwc(k,j) = gvdwc(k,j)  + dPOLdR1 * erhead_tail(k,1)
25194
25195        END DO
25196        RETURN
25197       END SUBROUTINE eqn
25198       SUBROUTINE enq(Epol)
25199       use calc_data
25200       use comm_momo
25201        double precision facd3, adler,epol
25202        alphapol2 = alphapol(itypj,itypi)
25203 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25204        R2 = 0.0d0
25205        DO k = 1, 3
25206 !c! Calculate head-to-tail distances
25207         R2=R2+(chead(k,2)-ctail(k,1))**2
25208        END DO
25209 !c! Pitagoras
25210        R2 = dsqrt(R2)
25211
25212 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25213 !c!     &        +dhead(1,1,itypi,itypj))**2))
25214 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25215 !c!     &        +dhead(2,1,itypi,itypj))**2))
25216 !c------------------------------------------------------------------------
25217 !c Polarization energy
25218        MomoFac2 = (1.0d0 - chi2 * sqom1)
25219        RR2  = R2 * R2 / MomoFac2
25220        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
25221        fgb2 = sqrt(RR2  + a12sq * ee2)
25222        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
25223        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
25224                 / (fgb2 ** 5.0d0)
25225        dFGBdR2 = ( (R2 / MomoFac2)  &
25226               * ( 2.0d0 - (0.5d0 * ee2) ) ) &
25227               / (2.0d0 * fgb2)
25228        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
25229                 * (2.0d0 - 0.5d0 * ee2) ) &
25230                 / (2.0d0 * fgb2)
25231        dPOLdR2 = dPOLdFGB2 * dFGBdR2
25232 !c!       dPOLdR2 = 0.0d0
25233        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25234 !c!       dPOLdOM1 = 0.0d0
25235        dPOLdOM2 = 0.0d0
25236 !c!-------------------------------------------------------------------
25237 !c! Return the results
25238 !c! (See comments in Eqq)
25239        DO k = 1, 3
25240         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25241        END DO
25242        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25243        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25244        facd2 = d2 * vbld_inv(j+nres)
25245        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25246        DO k = 1, 3
25247         condor = (erhead_tail(k,2) &
25248        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
25249
25250         gvdwx(k,i) = gvdwx(k,i) &
25251                    - dPOLdR2 * (erhead_tail(k,2) &
25252        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
25253         gvdwx(k,j) = gvdwx(k,j)   &
25254                    + dPOLdR2 * condor
25255
25256         gvdwc(k,i) = gvdwc(k,i) &
25257                    - dPOLdR2 * erhead_tail(k,2)
25258         gvdwc(k,j) = gvdwc(k,j) &
25259                    + dPOLdR2 * erhead_tail(k,2)
25260
25261        END DO
25262       RETURN
25263       END SUBROUTINE enq
25264       SUBROUTINE eqd(Ecl,Elj,Epol)
25265       use calc_data
25266       use comm_momo
25267        double precision  facd4, federmaus,ecl,elj,epol
25268        alphapol1 = alphapol(itypi,itypj)
25269        w1        = wqdip(1,itypi,itypj)
25270        w2        = wqdip(2,itypi,itypj)
25271        pis       = sig0head(itypi,itypj)
25272        eps_head   = epshead(itypi,itypj)
25273 !c!-------------------------------------------------------------------
25274 !c! R1 - distance between head of ith side chain and tail of jth sidechain
25275        R1 = 0.0d0
25276        DO k = 1, 3
25277 !c! Calculate head-to-tail distances
25278         R1=R1+(ctail(k,2)-chead(k,1))**2
25279        END DO
25280 !c! Pitagoras
25281        R1 = dsqrt(R1)
25282
25283 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25284 !c!     &        +dhead(1,1,itypi,itypj))**2))
25285 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25286 !c!     &        +dhead(2,1,itypi,itypj))**2))
25287
25288 !c!-------------------------------------------------------------------
25289 !c! ecl
25290        sparrow  = w1 * Qi * om1
25291        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
25292        Ecl = sparrow / Rhead**2.0d0 &
25293            - hawk    / Rhead**4.0d0
25294        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
25295                  + 4.0d0 * hawk    / Rhead**5.0d0
25296 !c! dF/dom1
25297        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
25298 !c! dF/dom2
25299        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
25300 !c--------------------------------------------------------------------
25301 !c Polarization energy
25302 !c Epol
25303        MomoFac1 = (1.0d0 - chi1 * sqom2)
25304        RR1  = R1 * R1 / MomoFac1
25305        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
25306        fgb1 = sqrt( RR1 + a12sq * ee1)
25307        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
25308 !c!       epol = 0.0d0
25309 !c!------------------------------------------------------------------
25310 !c! derivative of Epol is Gpol...
25311        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0) &
25312                / (fgb1 ** 5.0d0)
25313        dFGBdR1 = ( (R1 / MomoFac1)  &
25314              * ( 2.0d0 - (0.5d0 * ee1) ) ) &
25315              / ( 2.0d0 * fgb1 )
25316        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1)) &
25317                * (2.0d0 - 0.5d0 * ee1) ) &
25318                / (2.0d0 * fgb1)
25319        dPOLdR1 = dPOLdFGB1 * dFGBdR1
25320 !c!       dPOLdR1 = 0.0d0
25321        dPOLdOM1 = 0.0d0
25322        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
25323 !c!       dPOLdOM2 = 0.0d0
25324 !c!-------------------------------------------------------------------
25325 !c! Elj
25326        pom = (pis / Rhead)**6.0d0
25327        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25328 !c! derivative of Elj is Glj
25329        dGLJdR = 4.0d0 * eps_head &
25330           * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
25331           +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25332        DO k = 1, 3
25333         erhead(k) = Rhead_distance(k)/Rhead
25334         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
25335        END DO
25336
25337        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25338        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25339        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
25340        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
25341        facd1 = d1 * vbld_inv(i+nres)
25342        facd2 = d2 * vbld_inv(j+nres)
25343        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
25344
25345        DO k = 1, 3
25346         hawk = (erhead_tail(k,1) +  &
25347         facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
25348
25349         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25350         gvdwx(k,i) = gvdwx(k,i)  &
25351                    - dGCLdR * pom&
25352                    - dPOLdR1 * hawk &
25353                    - dGLJdR * pom
25354
25355         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25356         gvdwx(k,j) = gvdwx(k,j)    &
25357                    + dGCLdR * pom  &
25358                    + dPOLdR1 * (erhead_tail(k,1) &
25359        -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres))) &
25360                    + dGLJdR * pom
25361
25362
25363         gvdwc(k,i) = gvdwc(k,i)          &
25364                    - dGCLdR * erhead(k)  &
25365                    - dPOLdR1 * erhead_tail(k,1) &
25366                    - dGLJdR * erhead(k)
25367
25368         gvdwc(k,j) = gvdwc(k,j)          &
25369                    + dGCLdR * erhead(k)  &
25370                    + dPOLdR1 * erhead_tail(k,1) &
25371                    + dGLJdR * erhead(k)
25372
25373        END DO
25374        RETURN
25375       END SUBROUTINE eqd
25376       SUBROUTINE edq(Ecl,Elj,Epol)
25377 !       IMPLICIT NONE
25378        use comm_momo
25379       use calc_data
25380
25381       double precision  facd3, adler,ecl,elj,epol
25382        alphapol2 = alphapol(itypj,itypi)
25383        w1        = wqdip(1,itypi,itypj)
25384        w2        = wqdip(2,itypi,itypj)
25385        pis       = sig0head(itypi,itypj)
25386        eps_head  = epshead(itypi,itypj)
25387 !c!-------------------------------------------------------------------
25388 !c! R2 - distance between head of jth side chain and tail of ith sidechain
25389        R2 = 0.0d0
25390        DO k = 1, 3
25391 !c! Calculate head-to-tail distances
25392         R2=R2+(chead(k,2)-ctail(k,1))**2
25393        END DO
25394 !c! Pitagoras
25395        R2 = dsqrt(R2)
25396
25397 !c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
25398 !c!     &        +dhead(1,1,itypi,itypj))**2))
25399 !c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
25400 !c!     &        +dhead(2,1,itypi,itypj))**2))
25401
25402
25403 !c!-------------------------------------------------------------------
25404 !c! ecl
25405        sparrow  = w1 * Qi * om1
25406        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
25407        ECL = sparrow / Rhead**2.0d0 &
25408            - hawk    / Rhead**4.0d0
25409 !c!-------------------------------------------------------------------
25410 !c! derivative of ecl is Gcl
25411 !c! dF/dr part
25412        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0 &
25413                  + 4.0d0 * hawk    / Rhead**5.0d0
25414 !c! dF/dom1
25415        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
25416 !c! dF/dom2
25417        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
25418 !c--------------------------------------------------------------------
25419 !c Polarization energy
25420 !c Epol
25421        MomoFac2 = (1.0d0 - chi2 * sqom1)
25422        RR2  = R2 * R2 / MomoFac2
25423        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
25424        fgb2 = sqrt(RR2  + a12sq * ee2)
25425        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
25426        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0) &
25427                / (fgb2 ** 5.0d0)
25428        dFGBdR2 = ( (R2 / MomoFac2)  &
25429                * ( 2.0d0 - (0.5d0 * ee2) ) ) &
25430                / (2.0d0 * fgb2)
25431        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2)) &
25432                 * (2.0d0 - 0.5d0 * ee2) ) &
25433                 / (2.0d0 * fgb2)
25434        dPOLdR2 = dPOLdFGB2 * dFGBdR2
25435 !c!       dPOLdR2 = 0.0d0
25436        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
25437 !c!       dPOLdOM1 = 0.0d0
25438        dPOLdOM2 = 0.0d0
25439 !c!-------------------------------------------------------------------
25440 !c! Elj
25441        pom = (pis / Rhead)**6.0d0
25442        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
25443 !c! derivative of Elj is Glj
25444        dGLJdR = 4.0d0 * eps_head &
25445            * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0)) &
25446            +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
25447 !c!-------------------------------------------------------------------
25448 !c! Return the results
25449 !c! (see comments in Eqq)
25450        DO k = 1, 3
25451         erhead(k) = Rhead_distance(k)/Rhead
25452         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
25453        END DO
25454        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25455        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25456        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
25457        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
25458        facd1 = d1 * vbld_inv(i+nres)
25459        facd2 = d2 * vbld_inv(j+nres)
25460        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
25461        DO k = 1, 3
25462         condor = (erhead_tail(k,2) &
25463        + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
25464
25465         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25466         gvdwx(k,i) = gvdwx(k,i) &
25467                   - dGCLdR * pom &
25468                   - dPOLdR2 * (erhead_tail(k,2) &
25469        -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres))) &
25470                   - dGLJdR * pom
25471
25472         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25473         gvdwx(k,j) = gvdwx(k,j) &
25474                   + dGCLdR * pom &
25475                   + dPOLdR2 * condor &
25476                   + dGLJdR * pom
25477
25478
25479         gvdwc(k,i) = gvdwc(k,i) &
25480                   - dGCLdR * erhead(k) &
25481                   - dPOLdR2 * erhead_tail(k,2) &
25482                   - dGLJdR * erhead(k)
25483
25484         gvdwc(k,j) = gvdwc(k,j) &
25485                   + dGCLdR * erhead(k) &
25486                   + dPOLdR2 * erhead_tail(k,2) &
25487                   + dGLJdR * erhead(k)
25488
25489        END DO
25490        RETURN
25491       END SUBROUTINE edq
25492       SUBROUTINE edd(ECL)
25493 !       IMPLICIT NONE
25494        use comm_momo
25495       use calc_data
25496
25497        double precision ecl
25498 !c!       csig = sigiso(itypi,itypj)
25499        w1 = wqdip(1,itypi,itypj)
25500        w2 = wqdip(2,itypi,itypj)
25501 !c!-------------------------------------------------------------------
25502 !c! ECL
25503        fac = (om12 - 3.0d0 * om1 * om2)
25504        c1 = (w1 / (Rhead**3.0d0)) * fac
25505        c2 = (w2 / Rhead ** 6.0d0) &
25506           * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
25507        ECL = c1 - c2
25508 !c!       write (*,*) "w1 = ", w1
25509 !c!       write (*,*) "w2 = ", w2
25510 !c!       write (*,*) "om1 = ", om1
25511 !c!       write (*,*) "om2 = ", om2
25512 !c!       write (*,*) "om12 = ", om12
25513 !c!       write (*,*) "fac = ", fac
25514 !c!       write (*,*) "c1 = ", c1
25515 !c!       write (*,*) "c2 = ", c2
25516 !c!       write (*,*) "Ecl = ", Ecl
25517 !c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
25518 !c!       write (*,*) "c2_2 = ",
25519 !c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
25520 !c!-------------------------------------------------------------------
25521 !c! dervative of ECL is GCL...
25522 !c! dECL/dr
25523        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
25524        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0) &
25525           * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
25526        dGCLdR = c1 - c2
25527 !c! dECL/dom1
25528        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
25529        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25530           * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
25531        dGCLdOM1 = c1 - c2
25532 !c! dECL/dom2
25533        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
25534        c2 = (-6.0d0 * w2) / (Rhead**6.0d0) &
25535           * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
25536        dGCLdOM2 = c1 - c2
25537 !c! dECL/dom12
25538        c1 = w1 / (Rhead ** 3.0d0)
25539        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
25540        dGCLdOM12 = c1 - c2
25541 !c!-------------------------------------------------------------------
25542 !c! Return the results
25543 !c! (see comments in Eqq)
25544        DO k= 1, 3
25545         erhead(k) = Rhead_distance(k)/Rhead
25546        END DO
25547        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
25548        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
25549        facd1 = d1 * vbld_inv(i+nres)
25550        facd2 = d2 * vbld_inv(j+nres)
25551        DO k = 1, 3
25552
25553         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
25554         gvdwx(k,i) = gvdwx(k,i)    - dGCLdR * pom
25555         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
25556         gvdwx(k,j) = gvdwx(k,j)    + dGCLdR * pom
25557
25558         gvdwc(k,i) = gvdwc(k,i)    - dGCLdR * erhead(k)
25559         gvdwc(k,j) = gvdwc(k,j)    + dGCLdR * erhead(k)
25560        END DO
25561        RETURN
25562       END SUBROUTINE edd
25563       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
25564 !       IMPLICIT NONE
25565        use comm_momo
25566       use calc_data
25567
25568        real(kind=8) :: eheadtail,Egb,Ecl,Elj,Equad,Epol,Rb
25569        eps_out=80.0d0
25570        itypi = itype(i,1)
25571        itypj = itype(j,1)
25572 !c! 1/(Gas Constant * Thermostate temperature) = BetaT
25573 !c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
25574 !c!       t_bath = 300
25575 !c!       BetaT = 1.0d0 / (t_bath * Rb)i
25576        Rb=0.001986d0
25577        BetaT = 1.0d0 / (298.0d0 * Rb)
25578 !c! Gay-berne var's
25579        sig0ij = sigma( itypi,itypj )
25580        chi1   = chi( itypi, itypj )
25581        chi2   = chi( itypj, itypi )
25582        chi12  = chi1 * chi2
25583        chip1  = chipp( itypi, itypj )
25584        chip2  = chipp( itypj, itypi )
25585        chip12 = chip1 * chip2
25586 !       chi1=0.0
25587 !       chi2=0.0
25588 !       chi12=0.0
25589 !       chip1=0.0
25590 !       chip2=0.0
25591 !       chip12=0.0
25592 !c! not used by momo potential, but needed by sc_angular which is shared
25593 !c! by all energy_potential subroutines
25594        alf1   = 0.0d0
25595        alf2   = 0.0d0
25596        alf12  = 0.0d0
25597 !c! location, location, location
25598 !       xj  = c( 1, nres+j ) - xi
25599 !       yj  = c( 2, nres+j ) - yi
25600 !       zj  = c( 3, nres+j ) - zi
25601        dxj = dc_norm( 1, nres+j )
25602        dyj = dc_norm( 2, nres+j )
25603        dzj = dc_norm( 3, nres+j )
25604 !c! distance from center of chain(?) to polar/charged head
25605 !c!       write (*,*) "istate = ", 1
25606 !c!       write (*,*) "ii = ", 1
25607 !c!       write (*,*) "jj = ", 1
25608        d1 = dhead(1, 1, itypi, itypj)
25609        d2 = dhead(2, 1, itypi, itypj)
25610 !c! ai*aj from Fgb
25611        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
25612 !c!       a12sq = a12sq * a12sq
25613 !c! charge of amino acid itypi is...
25614        Qi  = icharge(itypi)
25615        Qj  = icharge(itypj)
25616        Qij = Qi * Qj
25617 !c! chis1,2,12
25618        chis1 = chis(itypi,itypj)
25619        chis2 = chis(itypj,itypi)
25620        chis12 = chis1 * chis2
25621        sig1 = sigmap1(itypi,itypj)
25622        sig2 = sigmap2(itypi,itypj)
25623 !c!       write (*,*) "sig1 = ", sig1
25624 !c!       write (*,*) "sig2 = ", sig2
25625 !c! alpha factors from Fcav/Gcav
25626        b1cav = alphasur(1,itypi,itypj)
25627 !       b1cav=0.0
25628        b2cav = alphasur(2,itypi,itypj)
25629        b3cav = alphasur(3,itypi,itypj)
25630        b4cav = alphasur(4,itypi,itypj)
25631        wqd = wquad(itypi, itypj)
25632 !c! used by Fgb
25633        eps_in = epsintab(itypi,itypj)
25634        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
25635 !c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
25636 !c!-------------------------------------------------------------------
25637 !c! tail location and distance calculations
25638        Rtail = 0.0d0
25639        DO k = 1, 3
25640         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
25641         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
25642        END DO
25643 !c! tail distances will be themselves usefull elswhere
25644 !c1 (in Gcav, for example)
25645        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
25646        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
25647        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
25648        Rtail = dsqrt(  &
25649           (Rtail_distance(1)*Rtail_distance(1))  &
25650         + (Rtail_distance(2)*Rtail_distance(2))  &
25651         + (Rtail_distance(3)*Rtail_distance(3)))
25652 !c!-------------------------------------------------------------------
25653 !c! Calculate location and distance between polar heads
25654 !c! distance between heads
25655 !c! for each one of our three dimensional space...
25656        d1 = dhead(1, 1, itypi, itypj)
25657        d2 = dhead(2, 1, itypi, itypj)
25658
25659        DO k = 1,3
25660 !c! location of polar head is computed by taking hydrophobic centre
25661 !c! and moving by a d1 * dc_norm vector
25662 !c! see unres publications for very informative images
25663         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
25664         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
25665 !c! distance
25666 !c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
25667 !c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
25668         Rhead_distance(k) = chead(k,2) - chead(k,1)
25669        END DO
25670 !c! pitagoras (root of sum of squares)
25671        Rhead = dsqrt(   &
25672           (Rhead_distance(1)*Rhead_distance(1)) &
25673         + (Rhead_distance(2)*Rhead_distance(2)) &
25674         + (Rhead_distance(3)*Rhead_distance(3)))
25675 !c!-------------------------------------------------------------------
25676 !c! zero everything that should be zero'ed
25677        Egb = 0.0d0
25678        ECL = 0.0d0
25679        Elj = 0.0d0
25680        Equad = 0.0d0
25681        Epol = 0.0d0
25682        eheadtail = 0.0d0
25683        dGCLdOM1 = 0.0d0
25684        dGCLdOM2 = 0.0d0
25685        dGCLdOM12 = 0.0d0
25686        dPOLdOM1 = 0.0d0
25687        dPOLdOM2 = 0.0d0
25688        RETURN
25689       END SUBROUTINE elgrad_init
25690       end module energy